How to access reactive value in parent module? - r

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)

Related

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)

ShinyModules with "global" reactive values

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

Shiny modules: Destroy module ui if server-function fails

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)

Dealing with nested selectizeInputs and modules

I am having trouble with nested selectizeInputs, i.e. a group of select inputs where the selection in the first determines the choices in the second, which control the choices in the third, and so on.
Let's say I have an select1 that lets you choose a dataset, and select2 which lets you pick a variable in the dataset. Obviously the choices in select2 depend on the selection in select1. I find that if a user selects a variable from select2, and then changes select1, it doesn't immediately wipe out the value from select2, but instead it goes through a reactive sequence with the new value in select1, and the old value from select2, which is suddenly referencing a variable in a different dataset, which is a problem.
Example:
library(shiny)
ui =fluidPage(
selectizeInput('d',choices=c('mtcars','iris'),
label="Datasets"),
uiOutput("vars"),
htmlOutput("out")
)
server = function(input, output, session) {
output$vars <- renderUI({
req(input$d)
selectizeInput("v",choices=names(get(input$d)), label="Variables",
options=list(onInitialize=I('function() {this.setValue("");}')))
})
output$out <- renderUI({
req(input$d,input$v)
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
})
}
runApp(list(ui = ui, server = server))
On launch, select mpg, and displays max value.
Now, after selecting mpg, if you switch to iris, you will get a barely noticeable error, then it corrects itself. This is a toy example, so the error is insignificant, but there could easily be cases where the error is much more dire (as is the case with the app I am currently developing).
Is there a way to handle nested selectizeInputs such that changes in an upstream selectizeInput won't evaluate with old values of down stream selectizeInputs when changed?
Thanks
edit: This issue turns out to have to do more with modules than anything else I believe:
library(shiny)
library(DT)
testModUI <- function(id) {
ns <- NS(id)
DT::dataTableOutput(ns("out"))
}
testMod <- function(input, output, session, data) {
output$out <- DT::renderDataTable({
data()
},caption="IN MODULE")
}
ui =fluidPage(
selectizeInput('d',choices=c('mtcars','iris'),
label="Datasets"),
uiOutput("vars"),
testModUI("test"),
DT::dataTableOutput("test2")
)
server = function(input, output, session) {
output$vars <- renderUI({
req(input$d)
selectizeInput("v",choices=names(get(input$d)), label="Variables",
options=list(onInitialize=I('function() {this.setValue("");}')))
})
observe({
req(input$d,input$v)#,get(input$d)[[input$v]])
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
callModule(testMod,"test",reactive(data.frame(v1=max(get(input$d)[[input$v]]))))
})
output$test2 <- DT::renderDataTable({
req(input$d,input$v)#,get(input$d)[[input$v]])
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
data.frame(v1=max(get(input$d)[[input$v]]))
},caption="OUTSIDE MODULE")
}
runApp(list(ui = ui, server = server))
Hello you can put condition to check if your code is going to run, here you just need that input$v to be a valid variable from input$d, so do :
output$out <- renderUI({
req(input$d,input$v)
if (input$v %in% names(get(input$d))) {
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
}
})
# or
output$out <- renderUI({
req(input$d,input$v)
validate(
need(input$v %in% names(get(input$d)), 'Wait.')
)
HTML(paste0("The max is ",max(get(input$d)[[input$v]])))
})
EDIT with module, you can define your module with an expression to validate like this :
testMod <- function(input, output, session, data, validExpr) {
output$out <- DT::renderDataTable({
validate(need(validExpr(), FALSE))
data()
},caption="IN MODULE")
}
And call the module in the server with the expression in a function :
observe({
req(input$d,input$v)
callModule(
module = testMod,
id = "test",
data = reactive({ data.frame(v1=max(get(input$d)[[input$v]])) }),
validExpr = function() input$v %in% names(get(input$d))
)
})

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