My app has several screens and I deal with it using tabsetPanel(), hiding the tab headers (I
leave them visible here for debugging) and selecting them using updateTabsetPanel()
It starts on a home screen (coded into mod_home_ui() / mod_home_server())
You push a button to trigger an action, there would be several but I just left one here, called "learn" (coded into mod_learn_ui() / mod_learn_server())
The "learn" module itself contains games, here I left only two games and used the same module functions for both for simplicity.
A reactive value panel_flag, determines which game should be played, here I force it to FALSE, which means game2 should be played.
This last step doesn't work as I expect, while messages show that the code went through the right updateTabsetPanel() call, the expected tab isn't selected, and moreover, the expected text isn't shown on top of the screen.
This looks like a namespacing issue but I don't understand what I did wrong here.
The code below can be copy pasted in one go to run the app and here's a gif of what would happen :
# main ui and server
app_ui <- function() {
tagList(
fluidPage(
title = "My app",
tabsetPanel(
id = "switcher",
#type = "hidden",
selected = "home",
tabPanel("home", mod_home_ui("home_ui")),
tabPanel("learn", mod_learn_ui("learn_ui"))
)
)
)
}
app_server <- function(input, output,session) {
learn <- callModule(mod_home_server, "home_ui")
observeEvent(learn(), {
message("In app_server: observeEvent on learn() to switch to 'learn' panel")
updateTabsetPanel(session, "switcher", selected = "learn")
})
callModule(mod_learn_server, "home_ui", learn = learn)
}
# home module
mod_home_ui <- function(id){
ns <- NS(id)
tagList(
textOutput(ns("some_text")),
actionButton(ns("learn"), "learn")
)
}
mod_home_server <- function(input, output, session){
output$some_text <- renderText("I expect clicking on the above to trigger game2, not game1")
ns <- session$ns
reactive({
res <- req(input$learn)
message(
'In mod_home_server: returning req(input$learn) in mod_home_server to trigger learn()')
res
})
}
# learn module
mod_learn_ui <- function(id){
ns <- NS(id)
tabsetPanel(
id = ns("switcher"),
#type = "hidden",
tabPanel("game1", mod_game_ui(ns("game1_ui"))),
tabPanel("game2", mod_game_ui(ns("game2_ui")))
)
}
mod_learn_server <- function(input, output, session, learn){
ns <- session$ns
panel_flag <- eventReactive(learn(), {
message('In mod_learn_server: eventReactive on learn() to trigger relevant game')
# in reality this would be computed or random
FALSE
})
observeEvent(panel_flag(), {
message('In mod_learn_server: observeEvent on panel_flag()')
if (panel_flag()) {
message('In mod_learn_server: select "game1" panel')
updateTabsetPanel(session, "switcher", selected = "game1")
} else {
message('In mod_learn_server: select "game2" panel')
updateTabsetPanel(session, "switcher", selected = "game2")
}
})
callModule(mod_game_server, "game1_ui")
callModule(mod_game_server, "game2_ui")
}
# game module
mod_game_ui <- function(id){
ns <- NS(id)
tagList(
textOutput(ns("some_text")),
"I expect another line of text above this one"
)
}
mod_game_server <- function(input, output, session){
ns <- session$ns
output$some_text <- renderText("I expect this to be shown")
}
library(shiny)
shinyApp(app_ui, app_server)
callModule(mod_learn_server, "learn_ui", learn = learn)
instead of
callModule(mod_learn_server, "home_ui", learn = learn)
should fix it.
To make sure this doesn't happen again I made a package that tests the consistency of the shiny code, it is designed with the {golem} framework and conventions in mind.
Install with remotes::install_github("moodymudskipper/shinycheck")
This is what I get when I run shinycheck::check_shiny() on my real app (which is slightly different from the above):
shinycheck::check_shiny()
-----------------------------------------------------------------------
Check that all module scripts contain exactly 2 functions named appropriately
-----------------------------------------------------------------------
Check that all module ui functions use ns() or NS() on argument named id/inputId/outputId
-----------------------------------------------------------------------
Check that in ui, module ui functions, named `mod_MODULE_ui` refer to modules which exist and ids fed to them are prefixed with "MODULE_"
-----------------------------------------------------------------------
Check that ns() and NS() are never called in an argument that isn't id/inputId/outputId
-----------------------------------------------------------------------
Check that the module args of callModule are of the form "mod_MODULENAME_server", that there is an R file properly named for "MODULENAME", and that the id argument is prefixed by "MODULENAME_"
* In 'mod_main_server', a call to `callModule` has a module argument `mod_learn_server` and an `id` argument 'home_ui' that is not prefixed by the module name 'learn'
-----------------------------------------------------------------------
Check that modules and module ids mentionned on both ui and server side are consistent
* In 'mod_main_ui' we find the module id 'learn_ui' but we don't find it in 'mod_main_server'
We find :
In 'mod_main_server', a call to callModule has a module argument mod_learn_server and an id argument 'home_ui' that is not prefixed by the module name 'learn'
In 'mod_main_ui' we find the module id 'learn_ui' but we don't find it in 'mod_main_server'
This would have made debugging trivial.
See more at https://github.com/moodymudskipper/shinycheck
Related
I build a shiny app that need to add pieces of UI dynamically based on some parameter I'll know only in real time. I created a simplistic reconstruction of my needs, and encountered a problem I describe below
so in my example I have a module called mblock. for the sake of this example it only displays a text. the actual text to display is decided at run time, and so is the number of texts (and hence blocks) will be decided at runtime
for the specific example I set texts to be a fixed vector containing all the texts to be shown, but in reality it will be computed as a reactive object. the code is below:
library(shiny)
#block module
mblockUI = function(id) {
ns = NS(id)
fluidRow(
textOutput(ns("text"))
)
}
mblock = function(input,output,session,actual_text) {
output$text = renderText({actual_text})
}
# Define the main ui
ui <- fluidPage(
uiOutput("all_blocks"),
actionButton("submit","submit")
)
# Define server logic
server <- function(input, output) {
texts = c("aaaa","bbbb","cccc") #this is a sample vector of texts to be shown in blocks
output$all_blocks = renderUI({
for(i in 1:length(texts)) {
mname = paste0("block",i) #block name to be created (the name of the module)
#print(mname)
insertUI("#submit","beforeBegin",mblockUI(mname)) #adding the ui
#now adding the server side of each block
#also passing the text to be shown
callModule(mblock,mname,texts[i])
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
The problem is that all the blocks show the same text (the last one). and I don't understand why
any ideas how to fix the code? what do I miss
(shiny version 1.4.0)
First of all, insertUI is able to work "on its own" and doesn't need renderUI. You can put it in an observe environment instead. However, be careful of the output of insertUI since it is persistent, as explained in the documentation of this function:
Unlike renderUI(), the UI generated with insertUI() is persistent: once it's created, it stays there until removed by removeUI(). Each new call to insertUI() creates more UI objects, in addition to the ones already there (all independent from one another). To update a part of the UI (ex: an input object), you must use the appropriate render function or a customized reactive function.
I don't know why but the for loop doesn't work (as your example shows) whereas lapply does (see this answer for example).
Here's your example with these corrections:
library(shiny)
#block module
mblockUI = function(id) {
ns = NS(id)
fluidRow(
textOutput(ns("text"))
)
}
mblock = function(input,output,session,actual_text) {
output$text = renderText({actual_text})
}
# Define the main ui
ui <- fluidPage(
actionButton("submit","submit")
)
# Define server logic
server <- function(input, output) {
texts = c("aaaa","bbbb","cccc") #this is a sample vector of texts to be shown in blocks
observe({
lapply(1:length(texts), function(i) {
mname = paste0("block",i) #block name to be created (the name of the module)
#print(mname)
insertUI("#submit","beforeBegin",mblockUI(mname)) #adding the ui
#now adding the server side of each block
#also passing the text to be shown
callModule(mblock,mname,texts[i])
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm traying to create an app that reads some user and password and then create a tabsetPanel inside a renderUI.
The app is supposed to read a code and type number from a data base and if the type is 1 then hides some tabPanel, however all the tabpanels are always shown.
library(shiny)
library(RPostgreSQL)
con=dbConnect(........)
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
uiOutput("panel")
)
server <- function(input, output, session) {
observeEvent({input$go}, {
code<-dbGetQuery(con,"SELECT type FROM table")[[1]]
#code is a number
if(dim(code)[1]==1){
type=reactive(dbGetQuery(con,"SELECT type FROM table2")[[1]])
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
observe({
if(type()==1){
hideTab(inputId = "tab", target = "Tab1")
}
})
}
})
}
shinyApp(ui, server)
The problem is that de observer is executed before the renderUI and doesn't re-execute, I think.
Generally speaking, you've mixed up 3 different processes.
Checking the user has access can be put in a separate function, outside of the scope of server, simply returning TRUE or FALSE (and possibly an error).
Dynamically loading the tabs. If this must only occur after the user has logged in, you can simply opt to not display Tab1. If the tabs has to be loaded regardless (but still dynamically), put it outside of the scope of observeEvent({input$go}, {...}). Consider, just for now, to setup the tabsetpanel with tabs in the ui.
Showing/hiding the tab.
Within a reactive/observe, you do not need to use additional reactives. They already are set to run. So type should be just be type = dbGetQuery(...), and the observe nested within an observe/observeEvent makes no sense.
Lastly, to debug why the tab is not hidden, use the good ol' fashioned print and look at your console. Try updating to
observe({
cat('Testing type: ', type(), '\n')
if(type()==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
and watch out for those messages in your console. Are they printed? Then the fault might be on the client-side (perhaps you mispelled something). Are the messages missing? Then you know the code never executed, and you'll have to investigate why.
Update:
Looking further into the matters, try using the browsers Inspect-function. For the viewer in Rstudio (and Chrome), you can right-click and select "Inspect element". A new window appears (or is docked within the window), which allows you to inspect the HTML DOM and view the JavaScript console. Here, we notice an important message:
Uncaught There is no tabsetPanel (or navbarPage or navlistPanel) with id equal to 'tab'
Simply put, the hideTab command is sent before the client has finished loading the tabpanels.
One solution, that did not work, is as follows:
server <- function(input, output, session) {
type <- reactiveVal(0)
type_delayed <- debounce(type, Inf)
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type(dbGetQuery(con,"SELECT type FROM table2")[[1]])
type(1)
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
}
})
observe({
cat('Testing type: ', type_delayed(), '\n')
if( type_delayed() ==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
}
I.e., we delay the execution of hiding the tab. Except it's a bad solution, because you have to choose a timing that is as soon as possible, but not so soon that the client isn't ready.
I suggest the following solution: Instead of hiding the panel, don't add it until you need it:
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
actionButton("add", "Add tab"),
uiOutput("panel")
)
server <- function(input, output, session) {
i <- 1
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type <- dbGetQuery(con,"SELECT type FROM table2")[[1]]
type <- 1
#type() is a number
output$panel=renderUI({
if (type == 1) {
i <<- 1
tabsetPanel(
id = "tab",
tabPanel("Tab1")
)
} else {
i <<- 2
tabsetPanel(
id = "tab",
tabPanel("Tab1"),tabPanel("Tab2")
)
}
})
}
})
observeEvent(input$add, {
i <<- i + 1
appendTab('tab', tabPanel(paste0('Tab', i)))
})
}
I am trying to write a Shiny module which shows a conditionalPanel based on input from the global UI. In the minimal example below the conditionalPanel should show a radioButtons widget when a checkbox in the global UI is clicked, but I can't get it to work.
What am I doing wrong?
library(shiny)
conditional <- function(input, output, session, check){
output$check <- reactive({check()})
outputOptions(output, "check", suspendWhenHidden = FALSE)
output$conditional <- renderUI({
ns <- session$ns
conditionalPanel(
condition = 'output.check',
radioButtons(ns('radioItem'),
'Select option',
choices = c('option 1','option 2'))
)
})
}
conditionalUI <- function(id){
ns <- NS(id)
uiOutput(ns('conditional'))
}
ui <- fluidPage(
fluidRow(checkboxInput('check','Show')),
fluidRow(conditionalUI('mymod'))
)
server <- function(input, output, session) {
check <- reactive({input$check})
callModule(conditional, 'mymod', check = check)
}
shinyApp(ui = ui, server = server)
Simple fix - The condition should be condition = input.check instead of condition = output.check.
You are having a problem with the naming conventions that shiny modules enforce.
Although you have a similar output object in your module, it is not the same as in server. If you specify an output
func <- function(input, output, session) {
output$something <- (...)
}
inside a module, that you called with
callModule(func, 'someIdentifier')
then your output id, which shiny uses to reference all the elements, becomes
someIdentifier-something
You can test this by writing uiOutput("mymod-conditional") instead of uiOutput(ns('conditional')).
Normally, this shouldn't bother you, since modules work the way that all references are resolved within a module. But the conditionalPanel condition, being in JavaScript ("on the other side" so to say), must use global references.
So the fix for your problem would be to change the condition to
condition = 'output["mymod-check"]'
Note that dashes cant be used with JavaScript dot notation, so bracket notation has to be used.
A trick that helped me identify the problem, was to inject JavaScript into the condition in order to show the current value of output on the client side. I placed condition = 'console.log(output)' inside the conditionalPanel so you can inspect the available object in the browser console.
I am having a lot of trouble getting a search filtering module working.
I am to run stats on a large database of cat owner information.
I want my search module to bring up a list of possible owners(that the user can select from) based on a selection from a list of cat breeds.
I thought wrapping the updateSelectInput with observe and using a reactive cat owner expression would facilitate this, in the module, but it is not working( and I can't guess why this is happening or how to debug this). It worked in these other posts([1]:R shiny passing reactive to selectInput choices , [2]:using values from a reactive input to directly input into a custom function)
Why won't my selectInput update with cat owners?
library(shiny)
df=data.frame(
cat=c("tabby","DSH","MSH","LSH","DSH","MSH","LSH","sphinx"),
owner=c("Foo","Bar","Bash","Foo","Foo","Foo","Bar","Bash"),stringsAsFactors = F)
refinedSearch<-function(input, output, session){
ownsCat<-reactive({df[df$cat%in%input$cat,"owner"]})
observe({updateSelectInput(session, "ownerSelected",
label ="Owned By",choices = ownsCat())})
return()
}
refinedSearchUI<-function(id){
ns <- NS(id)
fluidRow(
column(4,selectInput(ns("cat"),"Cat",selectize = T,
choices =c("tabby","DSH","MSH","LSH","sphinx") )),
column(4,selectInput(ns("ownerSelected"),"Owned By","",selectize = T))
)
}
ui <- fluidPage(
h1("Find cats owners"),
fluidRow(column(10,offset=1, refinedSearchUI("tmp"))),
fluidRow(column(10,offset=1, actionButton("addFilter","Add a Filter",
icon = icon("plus"))))
)
server <- function(input, output,session) {
refinedSearch(input,output,session)
observeEvent(input$add, {insertUI(selector = "#addFilter",where = "beforeBegin",
ui = refinedSearch(input,output,session))})
}
shinyApp(ui = ui, server = server)
Thank y'all for you time.
There seems to be quite a bit of confusion on how to call modules. You need to use the callModule() function in the server. Also, when inserting UI (using the insertUI()function), you need to call the refinedSearchUI() function, not the refinedSearch() function (which, again, should always be called through callModule(), so it should never actually get called directly like that).
I'd recommend a re-reading of the modules article.
You also have a typo. The event in your observeEvent() function should be input$addFilter, not input$add (which doesn't exist, so that observer is never fired..)
If you change your server function to this, your app will work as expected:
server <- function(input, output,session) {
callModule(refinedSearch, "tmp")
observeEvent(input$addFilter, {
id <- paste0("filter_", input$add)
insertUI(selector = "#addFilter",where = "beforeBegin",
ui = refinedSearchUI(id))
callModule(refinedSearch, id)
})
}
I am trying to modularize a complex Shiny app for which I have a conditionalPanel that should only appear given a certain input state.
Before I made everything modular, the input and conditionalPanel were both in ui.R, and I could reference the input using something like this:
conditionalPanel("input.select == 'Option one'", p('Option one is selected'))
Now that I have modularized things, accessing the input is more complicated. I thought the following was the way to do it, but it doesn't quite work. (Here I've combined things into a single standalone script):
library(shiny)
## Module code for 'selectorUI' and 'selector'
selectorUI <- function(id) {
ns <- NS(id)
selectizeInput(inputId = ns('select'),
label = 'Make a choice:',
choices = c('Option one', 'Option two'))
}
selector <- function(input, output, session) {
reactive(input$select)
}
## Main app
ui <- shinyUI(fluidPage(
selectorUI('id1'),
conditionalPanel(condition = "output.selected == 'Option one'", p('Option one is selected.'))
))
server <- shinyServer(function(input, output, session) {
output$selected <- callModule(selector, 'id1')
})
shinyApp(ui = ui, server = server)
I think this should work, but it doesn't - it only works if I make another reference to output$selected in the main ui section:
ui <- shinyUI(fluidPage(
selectorUI('id1'),
textOutput('selected'), ## Adding just this one line makes the next line work
conditionalPanel(condition = "output.selected == 'Option one'", p('Option one is selected.'))
))
Unfortunately of course this has the unwanted effect of rendering the result of textOutput('selected'). I can only guess that the reason this works is because it somehow triggers the reactive in a way that the JavaScript reference alone does not.
Any idea how I should be getting this conditionalPanel to work properly?
Thank you..
EDIT: Turns out not actually a bug: https://github.com/rstudio/shiny/issues/1318. See my own answer below.
But also note that I actually like the renderUI solution given in the accepted answer better than my original conditionalPanel approach.
After calling the module the ID of selectizeInput is id1-select. In javaScript there are two ways of accessing object properties:
objectName.property or objectName['property']
Since there is - in the ID we have to refer to it via string, so the second method is way to go.
The condition in conditionalPanel becomes:
input['id1-select'] == 'Option one'
Full example:
library(shiny)
## Module code for 'selectorUI' and 'selector'
selectorUI <- function(id) {
ns <- NS(id)
selectizeInput(inputId = ns('select'),
label = 'Make a choice:',
choices = c('Option one', 'Option two'))
}
## Main app
ui <- shinyUI(fluidPage(
selectorUI('id1'),
conditionalPanel(condition = "input['id1-select'] == 'Option one'",
p('Option one is selected.'))
))
server <- shinyServer(function(input, output, session) {
})
shinyApp(ui = ui, server = server)
EDIT:
This does work, but doesn't it violate the notion of modularity? You would have to know the code for the module internally calls that input 'select' in order to construct 'id1-select'.
Yes, you're right.
According to this article, the trick you used i.e. assigning a module call to the output$selected and then accessing its value on the client side via output.selected should work but it doesn't. I don't know why...it is maybe a bug. (I have the newest shiny version from github)
The only thing I can think of is to use renderUI instead of conditionalPanel as in the example below:
library(shiny)
## Module code for 'selectorUI' and 'selector'
selectorUI <- function(id) {
ns <- NS(id)
selectizeInput(inputId = ns('select'),
label = 'Make a choice:',
choices = c('Option one', 'Option two'))
}
selector <- function(input, output, session) {
reactive(input$select)
}
## Main app
ui <- shinyUI(fluidPage(
selectorUI('id1'),
uiOutput("dynamic1")
))
server <- shinyServer(function(input, output, session) {
output$dynamic1 <- renderUI({
condition1 <- callModule(selector, 'id1') # or just callModule(selector, 'id1')()
if (condition1() == 'Option one') return(p('Option one is selected.'))
})
})
shinyApp(ui = ui, server = server)
Turns out it actually isn't a bug, just a little tricky. According to Joe Cheng,
Right--we don't, by default, calculate/render output values if they aren't going to be visible. And if we don't calculate them, you can't use them in conditions.
You can change this behavior this by setting an output to calculate every time, you can use this in your server.R (replace outputId with the corresponding value):
outputOptions(output, "outputId", suspendWhenHidden = FALSE)
So to fix the problem with my original example, we only need to add that one line to the server function:
server <- shinyServer(function(input, output, session) {
output$selected <- callModule(selector, 'id1')
outputOptions(output, 'selected', suspendWhenHidden = FALSE) # Adding this line
})