I have a largish shiny app, where multiple elements change reactiveVals. Now I want to port the app to use shiny modules to be able to test it more appropriately. But I am not able to access the reactive values that are defined inside the server function.
MWE
A simple app that highlights my thought process so far is this counter app.
The app consists two modules: counter and display
counter increases the reactive counter value on the click of a button
display watches the counter and displays its output to a text-field
The main part of the app is a "central" reactive value called counter_reactive, which holds the current count.
This value is set by the counter and read by the display module elements.
library(shiny)
######################
# Counter Module
counter_UI <- function(id) {
ns <- NS(id)
tagList(
actionButton(ns("button"), "Increase Count")
)
}
counter <- function(input, output, session) {
observeEvent(input$button, {
counter_reactive(counter_reactive() + 1)
cat("Increase Counter by 1 to", counter_reactive(), "\n")
})
}
######################
# Display Module
display_UI <- function(id) {
ns <- NS(id)
tagList(
verbatimTextOutput(ns("text_output"))
)
}
display <- function(input, output, session) {
observe({
cat("Print Value of Counter\n")
output$text_output <- renderText(sprintf("Counter is now %i", counter_reactive()))
})
}
######################
# Rest of the Shiny App
ui <- fluidPage(
counter_UI("counter1"),
display_UI("display1")
)
server <- function(input, output, session) {
# Note that counter_reactive is defined inside the "global" server function,
# as multiple modules should read and write to it.
counter_reactive <- reactiveVal(0)
callModule(counter, "counter1")
callModule(display, "display1")
}
shinyApp(ui, server)
However, this app throws the error Warning: Error in counter_reactive: could not find function "counter_reactive".
Any ideas how to get/change the reactive value inside the module?
Rubber-Ducky-Debugging (aka SO-Question Writing Debugging) to the rescue, this works:
Simply passing the reactive value to the functions like so
counter <- function(input, output, session, counter_reactive) {
observeEvent(input$button, {
counter_reactive(counter_reactive() + 1)
cat("Increase Counter by 1 to", counter_reactive(), "\n")
})
}
display <- function(input, output, session, counter_reactive) {
observe({
cat("Print Value of Counter\n")
output$text_output <- renderText(sprintf("Counter is now %i", counter_reactive()))
})
}
server <- function(input, output, session) {
counter_reactive <- reactiveVal(0)
callModule(counter, "counter1", counter_reactive)
callModule(display, "display1", counter_reactive)
}
Related
I'm new to R and Shiny, and I'm writing a Shiny app that allows the user to create/read/update/delete records in a MariaDB database. When the user adds a record, I want the UI to display the updated contents of the table.
It works if all the code is in a single app.R, but when I break it into Shiny modules (saveNew and displaytbl), I can't get the datatable to automatically update, probably because I haven't figured out the correct reactive 'plumbing' that I need to pass data between modules.
app.R:
library(shiny)
library(dplyr)
library(DT)
ui <- fluidPage(
fluidRow(
saveNewUI("saveNew")),
fluidRow(
displaytblUI("displaytbl")
)
)
server <- function(input, output, session) {
# Load initial contents from database
tibl <- reactiveVal(loadSites())
# Display table
observeEvent(tibl(), { # without observe(), can't access tibl outside reactive context
displaytblServer("displaytbl", tibl())
})
# Save a new record to the table, and update the tibl reactiveVal
tibl(saveNewServer("saveNew"))
}
shinyApp(ui, server)
displaytbl.R:
library(shiny)
library(DT)
displaytblUI <- function(id) {
ns <- NS(id)
tagList(
DT::dataTableOutput(ns("datatable"))
)
}
displaytblServer <- function(id, datatable) {
moduleServer(id, function(input, output, session) {
observeEvent(datatable, {
output$datatable <- renderDataTable(datatable())
})
})
}
saveNew.R:
library(shiny)
saveNewUI <- function(id) {
ns <- NS(id)
tagList(
textInput(ns("siteName"), "Add a site"),
actionButton(ns("btnSave"), "Save"),
)
}
saveNewServer <- function(id) {
moduleServer(id, function(input, output, session) {
observeEvent(input$btnSave, {
saveSite(input$siteName)
})
# Return the updated database table
reactive(loadSites())
})
}
database.R (helper functions):
loadSites <- function() {
query <- "SELECT * FROM names"
res <- as_tibble(dbGetQuery(pool, query))
}
saveSite <- function(siteName) {
query <- paste0("INSERT INTO names (name) VALUES (?)")
params <- list(siteName)
dbExecute(pool, query, params)
}
Expecting the datatable to update when the user clicks the Save button. The database gets updated, but the datatable in the UI does not (until I reload/refresh the app).
After incorporating suggestions from #remko-duursma, I was able to get rid of my error by removing the observeEvent() from my app server(), and also passing the tibl reactiveVal as an argument to saveNewServer(), where it's used to update the database. My working code is below.
app server function:
server <- function(input, output, session) {
# Load initial contents from database
tibl <- reactiveVal(loadSites())
# Display table
displaytblServer("displaytbl", tibl)
saveNewServer("saveNew", tibl)
}
saveNewServer function:
saveNewServer <- function(id, tibl) {
moduleServer(id, function(input, output, session) {
observeEvent(input$btnSave, {
saveSite(input$siteName)
tibl(loadSites())
})
})
}
displaytblServer function:
displaytblServer <- function(id, datatable) {
moduleServer(id, function(input, output, session) {
output$datatable <- renderDataTable(datatable())
})
}
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)
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)
I'm trying to modularize a shiny app. So far it worked out smoothly, but I'm having trouble designing a system with two modules A and B, where A needs data from B and B needs data from A.
To start off, following this tutorial (Shiny version 1.5) I got this very basic self-contained example to work.
library(shiny)
#######################
# FILE MODULE #
# Load and save value #
#######################
fileModuleUI <- function(id) {
ns <- NS(id)
tagList(
fileInput(ns("fileInput"), "Input"),
downloadButton(ns("fileOutput"), "Save problem")
)
}
fileModuleServer <- function(id, textFieldData) {
moduleServer(
id,
function(input, output, session) {
# Write observer
output$fileOutput <- downloadHandler(
filename = function() { "myfile.dcf" },
content = function(file) { dput(textFieldData(), file) }
)
# Read observers
userFile <- reactive({
validate(need(input$fileInput, message = FALSE))
input$fileInput
})
fileContent <- reactive({
dget(userFile()$datapath)
})
return(fileContent)
}
)
}
###############
# MAIN UI #
###############
ui <- fluidPage(
sidebarLayout(
sidebarPanel(fileModuleUI("dataHandler")),
mainPanel(textInput("mainData", label = "Type your data in here"))
)
)
server <- function(input, output, session) {
fileContent <- fileModuleServer("dataHandler", reactive(input$mainData))
observe({
updateTextInput(session, "mainData", value = fileContent())
})
}
shinyApp(ui = ui, server = server)
With this nifty tool I can load and save one line of text from a textInput in a file.
Now I would like to also modularize the content inside my mainPanel. Let's call it mainModule.
While it's simple enough to build the mainModuleUI, the mainModuleServer introduces some cross-dependency issue:
fileModuleServer needs to know of the textfield of mainModuleServer so it can save its value in a file
mainModuleServer needs to know of the file content from fileModuleServer so it can update its text input field when a file has been loaded
The servers thus may look a little like this:
fileModuleServer <- function(id, textFieldData) { ... }
mainModuleServer <- function(id, fileContent) { ... }
server <- function(input, output, session) {
# what to pass as second parameter?
fileContent <- fileModuleServer("dataHandler", ???)
# would passing fileContent even work?
mainModuleServer("mainPanel", fileContent)
}
What's a good way to work around that?
I got it to work by introducing a reactiveValue in my main app. Then I pass that value to my servers and either change its value by writing value('this is some new value') or read its value by calling value().
This may look something like this:
# Module A
moduleAServer <- function(id, someData) {
moduleServer(
id,
function(input, output, session) {
# when clicking on load-button, just pretend to load some data
observeEvent(input$load, {
someData('This is the new data!')
})
observeEvent(input$save, {
print(paste('Saving the following:', someData()))
})
}
)
}
# Module B
moduleBServer <- function(id, someData) {
moduleServer(
id,
function(input, output, session) {
# observe will be called when Module A changes the data inside someData
observe({
# not sure if I need this req
req(someData)
print(paste('some Data changed to', someData()))
})
}
)
}
mainServer <- function(input, output, session) {
someData <- reactiveVal('oh')
chosenFile <- moduleAServer('filePanel', someData)
inputServer <- moduleBServer('mainPanel', someData)
}
How to display a blank UI (alternatively destroy module UI), if the module server-function fails, without moving all the UI-code to the server function?
Simple reproducible example:
library(shiny)
my_module_ui <- function(id) {
ns <- NS(id)
tags$div(
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
}
my_module_server <- function(input, output, session) {
tryCatch({
my_data <- cars * "A" # fail for demo
# my_data <- cars
output$my_plot <- renderPlot({
cars2 <- my_data + rnorm(nrow(my_data))
plot(cars2)
})
}, error=function(cond) {
message("Destroy UI here!")
})
}
ui <- fluidPage(
my_module_ui("my_id")
)
server <- function(input, output, session) {
callModule(my_module_server, "my_id")
}
shinyApp(ui, server)
My current solution is to have nothing but a uiOutput() in my_module_ui and render the entire ui in the server function. I want to prevent this, since large modules get very messy if all UI-components are placed within the module server-function.
In addition I would preferably also like to avoid returning values from callModule() that destroy the UI and do this from within the server-function instead.
Thanks!
How about you assign a value to the session object and evaluate this value before you create the UI (from server side via renderUI().
1) Move rendering of UI to server side
Use renderUI(my_module_ui("my_id")) on server side and uiOutput("module") on ui side.
2) To detect whether your server module was successful assign a value to the session object
my_module_server <- function(input, output, session) {
tryCatch({
...
session$userData$mod_server <- TRUE
}, error = function(cond) {
session$userData$mod_server <- NULL
})
}
3) Use this value to make the call of your module ui conditional
output$module <- renderUI({
callModule(my_module_server, "my_id")
if(!is.null(session$userData$mod_server)) my_module_ui("my_id")
})
Reproducible example:
library(shiny)
my_module_ui <- function(id) {
ns <- NS(id)
tags$div(
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
}
my_module_server <- function(input, output, session) {
tryCatch({
my_data <- cars * "A" # fail for demo
# my_data <- cars
output$my_plot <- renderPlot({
cars2 <- my_data + rnorm(nrow(my_data))
plot(cars2)
})
session$userData$mod_server <- TRUE
}, error = function(cond) {
session$userData$mod_server <- NULL
})
}
ui <- fluidPage(
uiOutput("module")
)
server <- function(input, output, session) {
output$module <- renderUI({
callModule(my_module_server, "my_id")
if(!is.null(session$userData$mod_server)) my_module_ui("my_id")
})
}
shinyApp(ui, server)
With a little code reordering, and the use of the amazing shinyjs package this can be done.
Note that I added an input to simulate errors and not errors, to see how the UI dissapears. Also all is done in the server part of the module. I hope this will help you. The code has inline comments explaining the steps.
library(shiny)
library(shinyjs)
my_module_ui <- function(id) {
ns <- NS(id)
tagList(
# input added to be able to throw errors and see the ui dissapear
selectInput(
ns('trigger'), 'Error trigger',
choices = list('no error' = c(2,1), 'error' = c('A', 'B')),
selected = 2
),
tags$div(
# div with id, to select it with shinyjs and hide it if necessary
id = ns('hideable_div'),
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
)
}
my_module_server <- function(input, output, session) {
# get all the things prone to error in a reactive call, that way you capture the final
# result or a NULL reactive when an error occurs
foo <- reactive({
tryCatch({
if (input$trigger %in% c(2,1)) {
trigger <- as.numeric(input$trigger)
} else {
trigger <- input$trigger
}
cars * trigger
}, error=function(cond) {
message("Destroy UI here!")
})
})
# obseveEvent based on the error reactive, to check if hide or not the UI
observeEvent(foo(), {
# hide checking if foo is null, using shinyjs
if (is.null(foo())) {
shinyjs::hide('hideable_div')
} else {
shinyjs::show('hideable_div')
}
}, ignoreNULL = FALSE, ignoreInit = FALSE)
# outputs, with validation of the error reactive. That way code after validate is not
# executed but the app does not get blocked (gray)
output$my_plot <- renderPlot({
shiny::validate(
shiny::need(foo(), 'no data')
)
cars2 <- foo() + rnorm(nrow(foo()))
plot(cars2)
})
}
ui <- fluidPage(
# really important for shinyjs tu work!!!!!!!
shinyjs::useShinyjs(),
my_module_ui("my_id")
)
server <- function(input, output, session) {
callModule(my_module_server, "my_id")
}
shinyApp(ui, server)