Unable to lift state in Shiny - r

Question

I am trying to lift state of the number of bins one level up from a module. This is a common technique in react, and I suspect shiny as well, when some data needs to be shared between different components (modules in shiny parlance)
This is the code I currently have
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R", local=my <- new.env())
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("App 1", tabName="app1"),
menuItem("App 2", tabName="app2"),
id="selectedMenu"
)
),
dashboardBody(
uiOutput("foo")
)
)
server.R
library(shiny)
source("modules/my.R", local=my <- new.env())
server <- function(input, output) {
reactive = reactive({3})
callModule(my$my, "foo", numBins=reactive)
plot <- my$myUI("foo")
output$foo <- renderUI({
if (input$selectedMenu == "app1") {
return(plot)
} else {
return(br())
}
})
}
and this is the module
library(shiny)
myUI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
box(
plotOutput(outputId = ns("distPlot")),
width=12
)
),
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
)
}
my <- function(input, output, session, numBins) {
output$distPlot <- renderPlot({
numBins()
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = numBins() + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
observe({
updateSliderInput(session, "bins", value=numBins())
})
}
I am trying to lift numBins out at the server.R level, and inject it in the module. However, it seems that the plot is not re-rendered. Initialisation seems to work however. I get the right number of bins, but moving the slider does nothing.
Please feel free to comment on other things that look dodgy. I am just a beginner with shiny and R (I do however have experience with react)
Edit
I have a simpler version with just two sliders, trying to make one change when the other is moved, by having numBins shared between the two from below.
library(shiny)
library(shinydashboard)
source("modules/my.R", local=my <- new.env())
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
uiOutput("central")
)
)
library(shiny)
source("modules/my.R", local=my <- new.env())
server <- function(input, output) {
numBins = reactiveVal(value=3)
callModule(my$my, "slider1", id="slider1", numBins=numBins)
callModule(my$my, "slider2", id="slider2", numBins=numBins)
output$central <- renderUI({
tagList(
my$myUI("slider1"),
my$myUI("slider2")
)})
}
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, numBins) {
ns <- NS(id)
observeEvent(
numBins,
{
cat("1234", file=stderr())
updateSliderInput(session, ns("bins"), value=numBins())
})
}
Still not working and kind of ugly to have to provide the id twice for the server function.

Answer 1

I'm trying to answer your edited example with two synced sliders. My solution is to let the module return the value of the sliderInput, and also receive an input coupledValue which is used in in observeEvent to update the sliderInput value.
my.R
Somewhat counterintuitively (at least to me when I first learned about it), you do not need to wrap the id "bins" into an ns() inside the updateSliderInput().
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, coupledValue) {
observeEvent(coupledValue(), {
updateSliderInput(session, "bins", value=coupledValue())
})
return(reactive(input$bins))
}
server.R
The numBins() reactive becomes unnecessary, as well as the additional environment you provided within source().
library(shiny)
source("modules/my.R")
server <- function(input, output) {
valSlider1 <- callModule(my, "slider1", id="slider1", coupledValue = valSlider2)
valSlider2 <- callModule(my, "slider2", id="slider2", coupledValue = valSlider1)
}
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
myUI("slider1"),
myUI("slider2")
)
)
If you want to sync to multiple inputs, you can use return(list(input1 = ..., input2 = ...)) as your return value from the module. When you pass that whole named list into another module, e.g. with the name coupledValues, you will have to reference it as coupledValues$input1() and coupledValues$input2() (note the () after the $).

Answer 2

Discalimer: This answer is based on In sync sliderInput and textInput
I am not sure if this is the best use case for shiny modules. Anyways, here's a way without using modules. Let me know if using modules is a must and I'll try and update my answer.
library(shiny)
ui <- fluidPage(
lapply(1:2, function(x) {
sliderInput(paste0("slider", x), paste0("Slider ", x), min = 1, max = 50, value = 30)
}),
verbatimTextOutput("test")
)
server <- function(input, output, session) {
observeEvent(input$slider1, {
if(input$slider1 != input$slider2) {
updateSliderInput(session, "slider2", value = input$slider1)
}
})
observeEvent(input$slider2, {
if(input$slider1 != input$slider2) {
updateSliderInput(session, "slider1", value = input$slider2)
}
})
output$test <- renderPrint({
c("Slider 1" = input$slider1, "Slider 2" = input$slider2)
})
}
shinyApp(ui, server)

Answer 3

Using return works nice for smaller applications, though using a strategy of reactiveValues pays of in larger apps.
I found the strategy in a blog post by rTask Communication between modules and its whims
The idea is to use r as a reactiveValues and pass it to each callModule.
Inside the module, you create a new reactiveValues based on r, e.g. r$my <- reactiveValues()
Then you don't need to return your module output and you don't need to pass any reactive variable except for r
Here I edited your code according to this strategy (and a few minor things, posted already):
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
myUI("slider1"),
myUI("slider2")
)
)
server.R
library(shiny)
source("modules/my.R")
server <- function(input, output) {
r <- reactiveValues()
numBins = reactiveVal(value=3)
callModule(my, "slider1", id="slider1", r = r)
callModule(my, "slider2", id="slider2", r = r)
}
my.R
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, r) {
r$my <- reactiveValues()
observe({
r$my <- input$bins
})
observeEvent(
r$my,
{
cat("1234", file=stderr())
updateSliderInput(session, "bins", value=r$my)
})
}

Answer 4

Slightly too late to compete for the bounty. But as I have done the thinking, here is my contribution. This differs from all the existing answers in that it neither uses coupled sliders, nor observers.
First let me ensure I understand your intent: You want to pass the number of bins from the slider in the sub-module, back to the parent module, before passing it from the parent module into the output calculation of the (same) sub-module. (If I have misunderstood your intend, see note below for an alternative).
This would make more sense if you were passing values between two different sub-modules. Modules in Shiny are intended to pass their own values within themselves, so as to avoid cluttering the parent module.
If this is your intention, I recommend the following:
UI (essentially unchanged):
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("App 1", tabName="app1"),
menuItem("App 2", tabName="app2"),
id="selectedMenu"
)
),
dashboardBody(
uiOutput("foo")
)
)
Server:
library(shiny)
source("modules/my.R")
server <- function(input, output) {
resource_numBins = reactive({ # reactive value is defined
if(exists('my_realised')
& !is.null(my_realised$num_bin())){ # conditions to prevent errors/warnings
return(my_realised$num_bins())
}else{
return(3) # required initial value
}
})
# reactive value passed to module
my_realised <- callModule(my, "foo", numBins = resource_numBins)
# my_realised stores values returned by module
output$foo <- renderUI({
if (input$selectedMenu == "app1") {
return(myUI("foo", initial_num_bins = resource_numBins()))
} else {
return(br())
}
})
}
Module (some white space removed):
library(shiny)
myUI <- function(id, initial_num_bins) {
ns <- NS(id)
tagList(
fluidRow( box(
plotOutput(outputId = ns("distPlot")), width=12
) ),
fluidRow( box(
sliderInput(inputId = ns("bins"), label = "Number of bins:",
min = 1, max = 50, value = initial_num_bins),
width=12
) )
)
}
my <- function(input, output, session, numBins) { # module receives value from parent
output$distPlot <- renderPlot({
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = numBins() + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
return(list(num_bins = reactive({input$bins}))) # module returns slider value to parent
}
Note that the complexity of resource_numBins is due to it also being used as the initial value, and needing to persist when menu item "App 2" is selected. Without these additional requirements this reactive would simplify to:
resource_numBins = reactive({ # reactive value is defined
return(my_realised$num_bins())
})
As sub-modules will pass values between themselves without first needing to pass a value back to the parent, the other problem you might be seeking to solve is how to use a sub-module to update the value in a parent module. For this I suggest my existing answer here. Either approach will let you use the value from the sub-module in the parent module.