Using lapply() in renderUI() in Shiny Module - r

I am trying to convert a section of code into a Shiny Module, but my renderPlot() functions generated within an lapply() don't seem to be working. I have created a simple example below to demonstrate the issue.
(Note: Here I'm using renderText() calls, but the same behavior applies.)
app_normal.R:
library(shiny)
ui <- fixedPage(
h2("Normal example"),
uiOutput("test")
)
server <- function(input, output, session) {
output$test <- renderUI({
lapply(1:3, function(val) {
fluidRow(column(12,renderText(paste("Line", val))))
})
})
}
shinyApp(ui, server)
app_module.R:
library(shiny)
myModuleUI <- function(id) {
ns <- NS(id)
uiOutput(ns("test"))
}
myModule <- function(input, output, session) {
output$test <- renderUI({
lapply(1:3, function(val) {
fluidRow(column(12,renderText(paste("Line", val))))
})
})
}
ui <- fixedPage(
h2("Module example"),
myModuleUI("test_module")
)
server <- function(input, output, session) {
callModule(myModule, "test_module")
}
shinyApp(ui, server)
All of the div elements are being created, but they just fail to contain the plots/text. How do I properly use the Shiny renderText() or renderPlot() functions within renderUI()/lapply() calls within a module?

It appears that the approach I was taking using the renderText() and renderPlot() functions directly in a renderUI() works fine in the normal case, i.e. when not operating within a Shiny Module. Shiny automatically calls the necessary textOutput() or plotOutput() to generate the HTML. Some how this automatic link is broken when you are performing the same operations within a Shiny Module. I suspect this is due to the mismatch between assigning and referencing items in the output list due to the introduction of the ns() call when assigning outputIds as is done manually in a call to outputPlot() or outputText().
To successfully use renderUI within a Shiny Module, you need to separately call textOutput() and renderText(): textOutput in the lapply() in the renderUI(), and renderText() in an lapply() in an observe(). This allows us to introduce an ns() into the generation of the outputId for the textOutput() call.
Below I've included a refactoring of both app_normal.R and app_module.R that demonstrates the disentanglement of these two calls.
app_normal_observe.R:
library(shiny)
ui <- fixedPage(
h2("Normal example"),
uiOutput("test")
)
server <- function(input, output, session) {
output$test <- renderUI({
lapply(1:3, function(val) {
fluidRow(column(12,textOutput(paste0("line_", val))))
})
})
observe({
lapply(1:3, function(val) {
output[[paste0("line_", val)]] <- renderText(paste("Line", val))
})
})
}
shinyApp(ui, server)
app_module_observe.R:
library(shiny)
myModuleUI <- function(id) {
ns <- NS(id)
uiOutput(ns("test"))
}
myModule <- function(input, output, session) {
output$test <- renderUI({
lapply(1:3, function(val) {
fluidRow(column(12,textOutput(session$ns(paste0("line_", val)))))
})
})
observe({
lapply(1:3, function(val) {
output[[paste0("line_", val)]] <- renderText(paste("Line", val))
})
})
}
ui <- fixedPage(
h2("Module example"),
myModuleUI("test_module")
)
server <- function(input, output, session) {
callModule(myModule, "test_module")
}
shinyApp(ui, server)

Related

Creating navbarMenu and tabPanel using shiny modules

I want to create a shiny app that uses navbarMenu() and tabPanel() to display data tables. Instead of writing all of the codes in one app.R file, I plan to use the concept of shiny modules creating R/tabUI.R and R/tabServer.R to generate these tables.
However, I run into an error and cannot figure it out. Any suggestions and help are appreciated!
My code:
### R/tabUI.R
tabUI <- function(id) {
tagList(
navbarMenu("display table",
tabPanel(NS(id, "mtcars table"),
DT::dataTableOutput("table")
)
)
)
}
### R/tabServer.R
tabServer <- function(id) {
moduleServer(id, function(input, output, session){
output$table <- DT::renderDataTable(mtcars)
})
}
### app.R
library(shiny)
ui <- navbarPage("dashboard",
tabUI("table1")
)
server <- function(input, output, session){
tabServer("table1")
}
shinyApp(ui=ui, server=server)
Error:
> runApp()
Error: Navigation containers expect a collection of `bslib::nav()`/`shiny::tabPanel()`s and/or `bslib::nav_menu()`/`shiny::navbarMenu()`s. Consider using `header` or `footer` if you wish to place content above (or below) every panel's contents.
You can't use tagList() inside navbarPage() so you need to remove it from the module.
As a sidenote, you should define ns <- NS(id) at the beginning of the module and then wrap all ids in ns(). In your code, the table id was not wrapped in ns() so it wasn't displayed.
Fixed code:
### R/tabUI.R
tabUI <- function(id) {
ns <- NS(id)
navbarMenu("display table",
tabPanel(ns("mtcars table"),
DT::dataTableOutput(ns("table"))
)
)
}
### R/tabServer.R
tabServer <- function(id) {
moduleServer(id, function(input, output, session){
output$table <- DT::renderDataTable(mtcars)
})
}
### app.R
library(shiny)
ui <- navbarPage("dashboard",
tabUI("table1")
)
server <- function(input, output, session){
tabServer("table1")
}
shinyApp(ui=ui, server=server)

How to detect a button pressed in Shiny modules in R

I am stuck about how to know whether a button inside a Shiny module is pressed. In this simplified example below, I created a module (buttonUI, buttonServer): there is a button inside this module, and my goal is to "know" (detect) this button is pressed from outside of the module.
buttonUI <- function(id) {
ns <- NS(id)
tagList(actionButton(ns("btn"), "a button label")
)}
buttonServer <- function(id, parent) {
moduleServer(id,
## Below is the module function
function(input, output, session) {
ns <- session$ns
ret <- reactiveVal(0)
observeEvent(input$btn,{
message("inner", ret())
ret(ret()+1)
})
list(n = reactive(ret))
})
}
ui <- fluidPage(
buttonUI("mod")
)
server <- function(input, output, session) {
v = buttonServer("mod")
observeEvent(v$n, {
message("outer")
})
}
shinyApp(ui, server)
I expected to see many outputs of "outer" when I clicked the button, but I do not see any.
PS: I have tried to return a single reactive value (return(ret)) instead of a list (e.g., list(n = reactive(ret))). I found return(ret) will work, but do not know why it works. However, I need the module to return a list instead of a single value.
There is a trick to pass values from outside to inside shiny module and from inside to outside. It consists in using reactiveValues : you initialise a reactiveValues in your server, you pass it as an argument in you server module, and it is changed inside the module AND outside the module.
You can check this page for more examples.
PS: reactiveValues is a list, so you can pass as much variables as you want inside/ outstide your module(s)
buttonUI <- function(id) {
ns <- NS(id)
tagList(actionButton(ns("btn"), "a button label")
)}
buttonServer <- function(id, parent, rv) { #rv is an argument
moduleServer(id,
## Below is the module function
function(input, output, session) {
ns <- session$ns
ret <- reactiveVal(0)
observeEvent(input$btn,{
rv$btn <- input$btn #increment rv
message("rv_inner", rv$btn)
message("inner", ret())
ret(ret()+1)
})
list(n = reactive(ret)) # no need to return rv
})
}
ui <- fluidPage(
buttonUI("mod")
)
server <- function(input, output, session) {
rv <- reactiveValues(btn = NULL) # initialise reactiveValues
v = buttonServer("mod", rv = rv) # pass reactiveValues as argument
observeEvent(v$n, {
message("outer")
})
observeEvent(rv$btn, { #check rv$btn value
message("rv_outer", rv$btn)
})
}
shinyApp(ui, server)
Here I used a simple trick.
As stated before, you can return a reactive value from a moduleServer and use that value to determine if the button was pressed
In my case, I used an eventReactive() so you can tie a reactive value directly to the actions related to the button
library(shiny)
buttonUI <- function(id) {
ns <- NS(id)
actionButton(ns("btn"), "a button label")
}
buttonServer <- function(id) {
moduleServer(id, function(input, output, session) {
isPressed <- eventReactive(input$btn, {
if(input$btn){
"The button was pressed"
} else {
"The button was NOT pressed"
}
}, ignoreNULL = FALSE)
return(isPressed())
})
}
ui <- fluidPage(
buttonUI("mod"),
textOutput("text")
)
server <- function(input, output, session) {
output$text <- renderText({
buttonServer("mod")
})
}
shinyApp(ui, server)

Shiny Module for Displaying a Table

Getting started with shiny, I try to learn how to use the Shiny Module design pattern. As the most simple example, I want to display a dataset without any further interaction.
I wish to organise the UI in tabPanels of a navbarPage. Each panel is independent from each other, (except that all panels use a global database connection objects, but this does not bother me now).
Here is the code for the DT GUI element:
library(shiny)
library(DT)
tabTable <- function(id) {
ns <- shiny::NS(id)
tabPanel(
"Table",
shiny::dataTableOutput(ns("table"))
)
}
This is the server logic. I want it to draw the data table.
srvTable <- function(id, dat) shiny::moduleServer(id,
function(input, output, session) {
output$table <- shiny::renderDataTable({DT::datatable(dat)})
}
)
Now here is the definition of the ui and the server:
ui <- shiny::navbarPage(title="Test",
tabTable(id="iris"),
shiny::tabPanel(title="Scatter")
)
server <- function(input, output, session) {
srvTable(id="iris", dat=iris)
session$onSessionEnded(stopApp)
}
shiny::shinyApp(ui, server)
This app starts, it displays the navigation bar, but it does not show the dataset. Any hint where I put the command for that? The problem for me is that there is no obvious condition that the server module needs to react to. What is to do in this case?
Try this
library(shiny)
library(DT)
tabTable <- function(id) {
ns <- shiny::NS(id)
tabPanel(
"Table",
DTOutput(ns("table"))
)
}
srvTable <- function(id, dat) { shiny::moduleServer(id,
function(input, output, session) {
output$table <- renderDT({DT::datatable(dat)})
}
)}
ui <- shiny::navbarPage(title="Test",
tabTable(id="iris"),
shiny::tabPanel(title="Scatter")
)
server <- function(input, output, session) {
srvTable(id="iris", dat=iris)
session$onSessionEnded(stopApp)
}
shiny::shinyApp(ui, server)

Passing uiOutput between nested modules

In my app, I have two modules (nested) for which I want to pass uiOuput. In the example below, the output named "screen1" (created in the outer module)has to be passed to the inner module where it will be displayed. But It doesn't work..
Passing such uiOutput work from the original shinyApp to one module but I can't make it works between two modules.
innerUI <- function(id){
ns <- NS(id)
tagList(
h4("Inner module"),
uiOutput(ns('displayScreens'))
)
}
inner <- function(input, output, session, params){
output$displayScreens <- renderUI({
params()
})
}
outerUI <- function(id){
ns <- NS(id)
innerUI(ns('test1'))
}
outer <- function(input, output, session){
rv <- reactiveValues(
test = uiOutput("screen1")
)
callModule(inner, 'test1', params= reactive({rv$test}))
output$screen1 <- renderUI({
h4("I am the screen 1 !")
})
}
ui <- fluidPage(
outerUI('test2')
)
server <- function(input, output, session){
callModule(outer, 'test2')
}
shinyApp(ui=ui, server=server)
Your problem seems to be one with namespaces. You are creating uiOutput("screen1") in outer and passing it to inner without a namespace. You could pass the uiOutput("screen1") in a reactive like this:
test <- reactive({
ns <- session$ns
uiOutput(ns("screen1"))
})
callModule(inner, 'test1', params=test)
This should work.

Shiny Modules not working with renderUI

I am using renderUI to optionally present a Table or Plot based on user selection of the visualization option. I am also using Shiny modules to present the same thing on multiple tabs. While I have gotten Shiny modules to work wonderfully in another app, I am struggling to get it to work with renderUI.
Here is a minimal piece of code that I came up with that shows the problem where nothing gets displayed on either tabs:
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
ui <- fluidPage(
tabBox(id = 'myBox', width = 12,
tabPanel('Tab1',
fluidRow(
myUI('tab1')
)),
tabPanel('Tab2',
fluidRow(
myUI('tab2')
))
)
)
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput('myText')
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'tab1', session = session, 'Hello Tab1')
callModule(myTextFunc, 'tab2', session = session, 'Hello Tab2')
}
shinyApp(ui = ui, server = server)
Any thoughts on what else I should be doing to make this work?
Replacing the Shiny module UI function and server functions as follows makes it work fine.
myUI <- function(id) {
ns <- NS(id)
fluidRow(
textOutput(ns('myFinalText'))
)
}
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderText({
text
})
}
You can get the namespace from the session object. Change myTextFunc in the initial app like this:
myTextFunc <- function(input, output, session, text) {
ns <- session$ns
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput(ns('myText'))
})
}
You shouldn't call output$ function from another output$ function - it's against Shiny design patterns.
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput(ns('myText'))
})
If you want to know, why it is very bad practice, watch Joe Cheng tutorial about 'Effective reactive programming' from this site: https://www.rstudio.com/resources/webinars/shiny-developer-conference/.
You should use rather reactiveValues or reactive expressions instead. What exactly you should use is dependent from what do you want to achieve, so it's hard to say without detailed example, but according to Joe Cheng everything can be accomplished without nesting outputs or observers.
Sorry for answering my own question...but for others looking for a similar solution, this may be of help.
Here is how I solved for the need to inherit Shiny module namespace on the server side to dynamically render UI. IF there is a better way to solve, please comment or post.
tab1NS <- NS('tab1')
tab2NS <- NS('tab2')
myUI <- function(ns) {
tagList(
fluidRow(
radioButtons(ns('type'), 'Select Visual:',
choices = c('Table' = 'table',
'Plot' = 'plot'))
),
fluidRow(
uiOutput(ns('myCars'))
)
)
}
ui <- fluidPage(
tabBox(id = 'myBox', width = 12,
tabPanel('Tab1',
fluidRow(
myUI(tab1NS)
)),
tabPanel('Tab2',
fluidRow(
myUI(tab2NS)
))
)
)
myTextFunc <- function(input, output, session, cars, ns) {
getMyCars <- reactive({
if (input$type == 'table') {
output$table <- renderDataTable({datatable(cars)})
dataTableOutput(ns('table'))
} else{
output$plot <- renderPlot({
plot(cars$wt, cars$mpg)
})
plotOutput(ns('plot'))
}
})
output$myCars <- renderUI({
getMyCars()
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'tab1', session = session,
mtcars[mtcars$am == 1, ], tab1NS)
callModule(myTextFunc, 'tab2', session = session,
mtcars[mtcars$am == 0, ], tab2NS)
}
shinyApp(ui = ui, server = server)
Replacing your functions with this renderUI equivalent also works:
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
text
})
}
Although this obviously does not capture the complexity of what you are really doing. There's something not right about using output$... and textOutput within the renderUI like that. I don't think that is necessary - you don't actually have to use the textOutput function to include text in your output.
EDIT: It occurs to me that the problem has to do with namespaces and modules. When you do output$myText <- renderText(text), the result ends up in the namespace of tab1 or tab2. For example, try changing your textOutput to
textOutput('tab1-myText')
and watch what happens. I think this is why having output$.. variables in your renderUI is problematic. You can access inputs via callModule and that should take care of any namespace issues.

Resources