Dealing with nested selectizeInputs and modules - r

I am having trouble with nested selectizeInputs, i.e. a group of select inputs where the selection in the first determines the choices in the second, which control the choices in the third, and so on.
Let's say I have an select1 that lets you choose a dataset, and select2 which lets you pick a variable in the dataset. Obviously the choices in select2 depend on the selection in select1. I find that if a user selects a variable from select2, and then changes select1, it doesn't immediately wipe out the value from select2, but instead it goes through a reactive sequence with the new value in select1, and the old value from select2, which is suddenly referencing a variable in a different dataset, which is a problem.
Example:
library(shiny)
ui =fluidPage(
selectizeInput('d',choices=c('mtcars','iris'),
label="Datasets"),
uiOutput("vars"),
htmlOutput("out")
)
server = function(input, output, session) {
output$vars <- renderUI({
req(input$d)
selectizeInput("v",choices=names(get(input$d)), label="Variables",
options=list(onInitialize=I('function() {this.setValue("");}')))
})
output$out <- renderUI({
req(input$d,input$v)
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
})
}
runApp(list(ui = ui, server = server))
On launch, select mpg, and displays max value.
Now, after selecting mpg, if you switch to iris, you will get a barely noticeable error, then it corrects itself. This is a toy example, so the error is insignificant, but there could easily be cases where the error is much more dire (as is the case with the app I am currently developing).
Is there a way to handle nested selectizeInputs such that changes in an upstream selectizeInput won't evaluate with old values of down stream selectizeInputs when changed?
Thanks
edit: This issue turns out to have to do more with modules than anything else I believe:
library(shiny)
library(DT)
testModUI <- function(id) {
ns <- NS(id)
DT::dataTableOutput(ns("out"))
}
testMod <- function(input, output, session, data) {
output$out <- DT::renderDataTable({
data()
},caption="IN MODULE")
}
ui =fluidPage(
selectizeInput('d',choices=c('mtcars','iris'),
label="Datasets"),
uiOutput("vars"),
testModUI("test"),
DT::dataTableOutput("test2")
)
server = function(input, output, session) {
output$vars <- renderUI({
req(input$d)
selectizeInput("v",choices=names(get(input$d)), label="Variables",
options=list(onInitialize=I('function() {this.setValue("");}')))
})
observe({
req(input$d,input$v)#,get(input$d)[[input$v]])
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
callModule(testMod,"test",reactive(data.frame(v1=max(get(input$d)[[input$v]]))))
})
output$test2 <- DT::renderDataTable({
req(input$d,input$v)#,get(input$d)[[input$v]])
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
data.frame(v1=max(get(input$d)[[input$v]]))
},caption="OUTSIDE MODULE")
}
runApp(list(ui = ui, server = server))

Hello you can put condition to check if your code is going to run, here you just need that input$v to be a valid variable from input$d, so do :
output$out <- renderUI({
req(input$d,input$v)
if (input$v %in% names(get(input$d))) {
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
}
})
# or
output$out <- renderUI({
req(input$d,input$v)
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
})
EDIT with module, you can define your module with an expression to validate like this :
testMod <- function(input, output, session, data, validExpr) {
output$out <- DT::renderDataTable({
validate(need(validExpr(), FALSE))
data()
},caption="IN MODULE")
}
And call the module in the server with the expression in a function :
observe({
req(input$d,input$v)
callModule(
module = testMod,
id = "test",
data = reactive({ data.frame(v1=max(get(input$d)[[input$v]])) }),
validExpr = function() input$v %in% names(get(input$d))
)
})

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)

Hide and Show Download Button Using Shiny Modularity

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.

How to pass Shiny browser timezone value from ui to server and readTzServer

I have a modularized application with two "ui" functions (ui and readTzUi) and two "server" functions. For the application I want to read the timezone from a users browser with readTzUi (input#client_time_zone_international) and pass it on to readTzServer.
I have worked out a reproducable example of the app.
As you can see the but_out and out variable can be accessed through the readTzServer, but input$client_time_zone_international results in a NULL value.
Although input$client_time_zone_international is not available in readTzServer, it is available in server (The values of timezone are printed in the console for both readTzServer and server)
A few things that I have tried so far are:
pass input$client_time_zone_international from server to readTzServer with Callmodule
create a global variable of input$client_time_zone_international
capture input$client_time_zone_international in a variable from the readTzUi with Shiny.setInputValue()
All these options did not result in passing the input$client_time_zone_international value to readTzServer.
I hope someone can help me with this problem.
library(shiny)
readTzUi <- function(id, label = "readTz"){
ns <- NS(id)
fluidPage(
tags$script('
$(function() {
$("input#client_time_zone_international").val(Intl.DateTimeFormat().resolvedOptions().timeZone)
});
'),
textInput("client_time_zone_international", "Time zone international", value = ""),
tags$br(),
actionButton(ns("button"), label = label),
verbatimTextOutput(ns("but_out")),
verbatimTextOutput(ns("out"))
)
}
readTzServer <- function(id){
moduleServer(
id,
function(input, output, session){
# This is where I need the timezone value
observe(print(input$client_time_zone_international))
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
})
output$but_out <- renderText({
count()
})
count
observe({
output$out <- renderText({
"Hello"
})
})
}
)
}
ui <- fluidPage(
readTzUi("readtz1", "Counter#2")
)
server <- function(input, output, session) {
readTzServer("readtz1")
observe(
print(input$client_time_zone_international)
)
}
shinyApp(ui, server)
This is example how to get a timezone:
library(shiny)
ui <- basicPage(
tags$script("$(document).on('shiny:sessioninitialized', function(event) {
var n = Intl.DateTimeFormat().resolvedOptions().timeZone;
Shiny.onInputChange('client_time', n);});")
)
server <- function(input, output, session) {
observe({
req(input$client_time)
print(input$client_time)
})
}
shinyApp (ui = ui, server = server)

How to access reactive value in parent module?

What I want to achieve is to get access to the reactive value passed to a parent module from a child module. The reproducible example below shows the idea. When i click the button in mod_server_btn then its value should be printed out in the console (from within parent module):
library(shiny)
mod_ui_btn <- function(id, label = "ui1UI") {
ns <- NS(id)
shinyUI(fluidPage(
actionButton(ns("confirm"), "Submit", class='btn-primary')
))
}
mod_server_btn <- function(input, output, session) {
cond <- reactive({ input$confirm})
return(cond)
}
ui =fluidPage(
mod_ui_btn("test"),
uiOutput("example")
)
server=shinyServer(function(input, output, session) {
value <- callModule(mod_server_btn,"test")
print(value)
#print(value$cond) # these 3 don't work either
#print(value()$cond)
#print(value())
})
shinyApp(ui=ui,server=server)
However, it doesn't work. When I click the button then I got a text: reactive({input$confirm}) in the console and it's not what I want, I need to access button value. General question is - is it possible at all to get access to reactive value in a parent module?
EDIT: #rbasa, #YBS thanks for your answers. In fact in my real app I need to return more than one reactive value to parent module. Below is slightly changed code - I added second button in mod_ui_btn - now I need to return values from both buttons to the server module. I made a list of reactives but can't get access to them using observe or output$example <-:
library(shiny)
mod_ui_btn <- function(id, label = "ui1UI") {
ns <- NS(id)
shinyUI(fluidPage(
actionButton(ns("confirm"), "Submit", class='btn-primary'),
actionButton(ns("confirm2"), "Submit2", class='btn-primary')
))
}
mod_server_btn <- function(input, output, session) {
return(
list(
cond = reactive({ input$confirm}),
cond2 = reactive({ input$confirm2})
)
)
}
ui =fluidPage(
mod_ui_btn("test"),
verbatimTextOutput("example"),
verbatimTextOutput("example2")
)
server=shinyServer(function(input, output, session) {
value <- callModule(mod_server_btn,"test")
output$example <- renderPrint(value$cond)
output$example2 <- renderPrint(value$cond2)
observe({
print(value$cond) #this is how I usually catch reactives - by their name
print(value$cond2)
})
})
shinyApp(ui=ui,server=server)
I usually use return(list(..some reactive values)) to return more than one ractive value to other module and catch then using their names in parent module. Here it doesn't work even if I use observe. No value is returned.
You can access with value(). I would recommend to change your mod_server_btn to the one shown below, and notice the call in server. EDIT: updated for multiple variables. Try this
library(shiny)
mod_ui_btn <- function(id, label = "ui1UI") {
ns <- NS(id)
shinyUI(fluidPage(
actionButton(ns("confirm"), "Submit", class='btn-primary'),
actionButton(ns("confirm2"), "Submit2", class='btn-primary')
))
}
mod_server_btn <- function(id) {
moduleServer(id, function(input, output, session) {
return(
list(
cond = reactive(input$confirm),
cond2 = reactive(input$confirm2)
)
)
})
}
ui =fluidPage(
mod_ui_btn("test"),
verbatimTextOutput("example"),
verbatimTextOutput("example2")
)
server=shinyServer(function(input, output, session) {
# value <- callModule(mod_server_btn,"test")
value <- mod_server_btn("test")
output$example <- renderPrint(value$cond())
output$example2 <- renderPrint(value$cond2())
observe({
print(value$cond()) #this is how I usually catch reactives - by their name
print(value$cond2())
})
})
shinyApp(ui=ui,server=server)

R Shiny - Isolating a reactive expression that uses req() to check preconditions

The app below contains a selectInput with two options iris and mtcars and a header that displays the current selection.
If the user selects iris, a DT of the corresponding dataset is rendered below the header.
If the user selects mtcars, nothing is rendered below the header.
Here is a screenshot:
I store the selected dataset in a reactive expression, sel_df. The expression checks if the user has selected iris using req(input$dataset=='iris') before returning the corresponding dataset:
sel_df = reactive({
req(input$dataset=='iris')
iris
})
sel_df is passed to renderDT which renders the datatable:
output$df = renderDT({
sel_df()
})
I then render some UI to display the current value of the selectInput using an h3 header, the datatable and a label for the datatable:
output$tbl = renderUI({
tagList(
h3(paste0('Selected:', input$dataset)), # Header should be visible regardless of the value of input$dataset
tags$label(class = 'control-label', style = if(!isTruthy(isolate(sel_df()))) 'display:none;', `for` = 'df', 'Data:'), # Label should only show if input$dataset == 'iris'
DTOutput('df')
)
})
I would like the datatable and its label to only be visible if sel_df outputs a dataset. But due to the way the app is structured, this requires output$tbl (the renderUI above) to take a dependency on sel_df, so that the entire UI chunk disappears whenever input$dataset == 'mtcars'.
My desired output requires output$tbl to only take a dependency on input$dataset, so that the h3 header is always visible regardless of the value of input$dataset. To do this, I tried 'isolating' sel_df using isolate, but output$tbl still calls sel_df each time it's invalidated.
I am not sure where I am going wrong here. I think I may be using isolate incorrectly but I don't know why and was wondering if someone could shed some light.
Here is the app in full:
library(shiny)
library(DT)
ui <- fluidPage(
selectInput('dataset', 'Dataset', c('iris', 'mtcars')),
uiOutput('tbl')
)
server <- function(input, output, session) {
sel_df = reactive({
req(input$dataset=='iris')
iris
})
output$df = renderDT({
sel_df()
})
output$tbl = renderUI({
tagList(
h3(paste0('Selected:', input$dataset)), # Header should be visible regardless of the value of input$dataset
tags$label(class = 'control-label', style = if(!isTruthy(isolate(sel_df()))) 'display:none;', `for` = 'df', 'Data:'), # Label should only show if input$dataset == 'iris'
DTOutput('df')
)
})
}
shinyApp(ui, server)
output$tbl depends on input$dataset, so naturally it is called each time the value of input$dataset changes. sel_df() also depends on input$dataset and gets called whenever it changes. This is all how it is expected to be, I don't think your label is called because it depends on sel_df().
However, please note that when sel_df is NULL, the taglist() call will also return NULL. This is because your sel_df() call fails silently when input$dataset != "iris", and consequently tagList fails as well:
If any of the given values is not truthy, the operation is stopped by raising a
"silent" exception (not logged by Shiny, nor displayed in the Shiny app's UI).
Try this:
server <- function(input, output, session) {
sel_df = reactive({
if(input$dataset=='iris') {
iris
} else {
NULL
}
})
You will find that with mtcars, the h3() tag is shown, but the label is hidden as desired.
If you would like to use req in sel_df() you could use a trycatch in renderDT this addresses the problem mentioned by #January, of tagsList failing when you do not select iris.
You will also need to modify the if statement to use is.null rather, as I use this as the default return value in the trycatch.
library(shiny)
library(DT)
ui <- fluidPage(
selectInput('dataset', 'Dataset', c('iris', 'mtcars')),
uiOutput('tbl')
)
server <- function(input, output, session) {
sel_df = reactive({
req(input$dataset=='iris')
iris
})
output$df = renderDT({
out <- tryCatch(sel_df(), error = function(e) NULL)
return(out)
})
output$tbl = renderUI({
tagList(
tags$h3(paste0('Selected:', input$dataset)), # Header should be visible regardless of the value of input$dataset
tags$label(class = 'control-label', style = if(is.null('df')) 'display:none;', `for` = 'df', 'Data:'), # Label should only show if input$dataset == 'iris'
DTOutput('df')
)
})
}
shinyApp(ui, server)

Resources