problem in adding several shiny modules using insertUI - r

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)

Related

Do functions defined within Shiny apps not search the enclosing environment?

I have a Shiny app that calls several custom functions in response to a click event. These custom functions make use of multiple reactive values and I didn't think I would need to pass all of those reactive values as arguments to the custom functions but it seems like I do.
I would have expected the app to behave like normal R where a custom function will search the immediate environment, then, upon not finding a variable, will search the enclosing environment and up the scope, only throwing an error if that variable's undefined at every level. Instead, when the function deals with reactive variables, it seems like code within the function is unaware of reactive variables defined outside of it. Is this true?
A quick demo app that crashes because identity_fun cannot find input$click:
library(shiny)
identity_fun <- function(x){
print(paste("Title's been changed", input$click, "times now"))
x
}
ui <- fillPage(
sidebarLayout(
sidebarPanel(
textInput("text", "Plot title here"),
actionButton("click", "Click when ready to apply it")
),
mainPanel(
plotOutput("mainplot")
)
)
)
server <- function(input, output){
input_text <- reactiveVal()
observeEvent(input$click, {
input_text(identity_fun(input$text))
})
output$mainplot <- renderPlot({
plot(1, main = input_text())
})
}
shinyApp(ui, server)
In base R, a variable outside the function is found trivially:
input <- list()
input$click <- 1
identity_fun("blah")
[1] "Title's been changed 1 times now"
[1] "blah"
and this different behavior took me by surprise when working with a Shiny app.
To fix the above app, I can pass the relevant information as an argument to identity_fun
identity_fun <- function(x, input_click){
print(paste("Title's been changed", input_click, "times now"))
x
}
and
observeEvent(input$click, {
input_text(identity_fun(input$text, input$click))
})
but I'm wondering if that's the best way of doing it. I realize this is probably intentional behavior because it seems complicated for the function to auto-detect that it uses input$click and invalidate if input$click changes, but Shiny's been magic to me before.
Is there a better way of passing reactive values to a function than by adding them as arguments?
The issue with you above example is, that identity_fun is defined outside of the server function. Shiny's input however is only available inside of the server function (there is no input variable in the global env. - you can check this e.g. via RStudio's environment tab).
The following works:
library(shiny)
ui <- fillPage(
sidebarLayout(
sidebarPanel(
textInput("text", "Plot title here"),
actionButton("click", "Click when ready to apply it")
),
mainPanel(
plotOutput("mainplot")
)
)
)
server <- function(input, output){
identity_fun <- function(x){
print(paste("Title's been changed", input$click, "times now"))
x
}
input_text <- reactiveVal()
observeEvent(input$click, {
print(identity_fun(input$text))
})
output$mainplot <- renderPlot({
plot(1, main = input_text())
})
}
shinyApp(ui, server)
Accordingly functions defined within Shiny apps work just like they do everywhere else in R.
However, I'd recommend to always pass function parameters explicitly to make your code more readable.
Please also check this article.

Unexpected output using `observeEvent`, `updateTabsetPanel` and nested modules

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

Render icon in R shiny based on condition

I am trying to render icons in my shiny dashboard based on a particular condition. Below is the code I am using to get the if else working . Since my code base is too big to share I am just posting the code for that particular portion:
output$cost_compare <-renderUI( ifelse(
last_week$cost < kpi_table$cost,
as.character(icon("angle-up")),
as.character(icon("angle-down"))
))
compareCostUI <- function(id) {
ns <- NS(id)
( uiOutput(ns("cost_compare")))
}
And I am using this in the ui inside a descriptionblock. Below is the code for it
descriptionBlock(
number = compareCostUI("pacing"))
What I am missing here due to which I can see the icon rendered
Ignore my last comment:
Using renderText is what you want to use if you are passing html strings to the UI. Returning character values in renderUI returns literal strings. Seems unintuitive.
I'm not sure if your compareCostUI function is causing any issues and I also didn't know the namespace of descriptionBlock but I made a small reproducible example of rendering an icon.
I'm also assuming that your two values last_week and kpi_table are reactive in some way? otherwise the output$cost_compare would actually never update.
ui <- shinyUI(
fluidPage(
actionButton("Press","press", icon = icon("refresh")),
uiOutput("cost_compare")
)
)
server <- function(input, output, session) {
output$cost_compare <- renderText({
if(input$Press%%2==0){
condition <- T
} else{
condition <-F
}
ifelse(condition,
as.character(icon("angle-up")), as.character(icon("angle-down")))
}
)
}
shinyApp(ui, server)

Include a conditionalPanel in a Shiny module with condition based on global input

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.

Change font markup (i.e. bold, italic) for checkboxGroupInput labels

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))

Resources