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)
})
}
Related
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
I am making an app with drag and drop feature using the ShinyDND package. I would like to pass a list from input as a parameter of dragSetUI, a function that needs to be run in ui.R. I tried renderUI and uiOutput, and it almost works, but the dragged elements fail to be dropped in the drop area. As you can see in the example below, nonreactive choices work like charm. I tried creating a reactive object as well as text output, but I could not find documentation on how to refer to these objects in ui.R. Normally one would refer to output$x as "x" in Output, but here, if I add anything between quotes, it reads as string. I am really stuck with this.
library(shiny)
library(shinyDND)
nonreactive_choices<-as.list(c("a","b","c"))
ui <- shinyUI(
mainPanel(
textInput("choices","Put here a,b,c:"),
dragSetUI("drag", textval = "reactive_choices"),
dragSetUI("drag", textval = "choice_rv"),
textOutput("reactive_choices"),
dragSetUI("drag", textval = nonreactive_choices),
dropUI("drop")
)
)
server = shinyServer(function(input, output,session) {
output$reactive_choices<-reactive({
strsplit(input$choices,",")
})
observe({
chlist<-strsplit(input$choices,",")
choice_rv<-reactiveVal(chlist)
})
})
# Run the application
shinyApp(ui = ui, server = server)
Let's see why the renderUI approach does not work with shinyDND. An app using shinyDND is linked to the dragndrop.js file, which is in the shinyDND folder. In this file one can see:
$(document).ready(function(){
......
$(".dragelement").on("dragstart",function(e){
e.originalEvent.dataTransfer.setData("Text",e.target.id);
});
......
});
This defines the action to perform on elements having class dragelement when a drag is starting, and this is defined when the document is ready. dragSetUI creates such elements.
When you use a dragSetUI inside a renderUI, this creates new elements of class dragelement. But the action defined on such elements in $(document).ready is not effective for these new elements, because this action has been defined just after the document is ready, and then before the effect of renderUI.
A solution consists in defining the action of the event dragstart inside the renderUI. This works:
library(shiny)
library(shinyDND)
nonreactive_choices<-as.list(c("a","b","c"))
ui <- shinyUI(
mainPanel(
textInput("choices","Put here d,e,f:"),
dragSetUI("drag", textval = nonreactive_choices),
uiOutput("dragset"),
dropUI("drop")
)
)
server = shinyServer(function(input, output,session) {
reactive_choices <- reactive({
strsplit(input$choices,",")[[1]]
})
output$dragset <- renderUI({
tagList(
dragSetUI("drag2", textval = as.list(reactive_choices())),
tags$script('$(".dragelement").on("dragstart",function(e){
e.originalEvent.dataTransfer.setData("Text",e.target.id);
});'
)
)
})
})
# Run the application
shinyApp(ui = ui, server = server)
Comment by #ismirsehregal helped me find the solution: shinyjqui can be used for my purposes and it seems to work from inside renderUI. Here is the edited code that does exactly what I needed.
library(shiny)
library(shinyjqui)
ui <- fluidPage(
textInput("choices","Put here a,b,c:"),
uiOutput("reactiveselect"),
orderInput(inputId = 'drop', label = 'Reactive drop', items = NULL,placeholder = "drop here..."),
verbatimTextOutput("droppedorder")
)
server <- function(input, output) {
output$reactiveselect <- renderUI({
req(input$choices)
reactiveitems<- unlist(strsplit(input$choices,","))
orderInput("groupstochoose", "groups to choose from:", connect='drop',items=reactiveitems)
})
output$droppedorder<-
renderPrint({input$drop_order})
}
shinyApp(ui, server)
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 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
})
I'm creating an web-app with Shiny in R. I have a dataset which I plot on the map. Using a checkboxGroupInput widget users are able to select categories they want to see on the map (or not). However, the dataset changes over time and not all categories are always available. To make clear which are available in the current set and which are not, I want to format the available categories as bold.
So far I've not been able to get a checkboxGroupInput widget to show with bold labels by the checkboxes. Is there a way to do that? I want some labels to be bold and others not. Also, using updateCheckboxGroupInput I'm able to change the options (i.e. show only available categories), but that not what I want/need.
I have tried for example:
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
But such an approach only displays the formatting tags as text in the user interface. Solutions using the HTML() function of Shiny doesn't seem to work either, or... I'm doing it wrong.
Any ideas?
Here is a simple Shiny interface example using the approach described above (which does not work):
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
server = function(input, output) {}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))
The next example DOES work, but it is a solution when initializing the checkbox group. Enabling the observe function in the server part shows that the same solution does not work for updateCheckboxGroupInput. That makes sense, since that function does not return HTML code. I don't know how to access the output of that update function, or how to solve it otherwise.
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
# observe({
# input$test
# gsub(">", ">", gsub("<", "<", updateCheckboxGroupInput(session, "test", choices=y)))
# })
}
ui = fluidPage(
gsub(">", ">", gsub("<", "<", checkboxGroupInput(inputId="test", label="this is a test", choices=x)))
)
runApp(list(ui = ui, server = server))
For now I found a solution. Not really elegant, and probably prone to errors, but it works. I found out that the < and > characters are escaped for HTML purposes by the htmltools function called escapeHtml. By temporarily replacing that function before the updateCheckboxGroupInput is called, by a dummy function, the text is not escaped. After the updateCheckboxGroupInput is called, htmlEscape of course needs to be restored.
An example that works. After launching the app, you need to check the first box to see it work:
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
observe({
value <- input$test
if (length(value) > 0 && value == 1) {
## save htmlEscape function and replace htmlEscape
saved.htmlEscape <- htmltools::htmlEscape
assignInNamespace("htmlEscape", function(x, attribute) return(x), "htmltools")
updateCheckboxGroupInput(session, "test", label="OK", choices=y)
## restore htmlEscape function
assignInNamespace("htmlEscape", saved.htmlEscape, "htmltools")
}
})
}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))