I am new to Shiny Modules, and I want to use the input from the sliderInput in (at least) two different elements. Therefore I created a little reprex. I want to have a histogram with a vertical line to display the slider value and a table in the main panel, which should be filtered based on the same slider value.
Because in practice I have a lot of sliders, I thought Shiny Modules would be a good thing way to structure and reduce the amount of code.
Unfortunately, I have a bug, already tried various things but couldn't find a way how to resolve it. I cannot access the slider value in the table and the histogram. Thanks in advance for your help.
library(shiny)
library(tidyverse)
ui_slider <- function(id, height = 140, label = "My Label") {
sliderInput(inputId = NS(id, "slider"), label = label, min = 0, max = 5, value = 1)
}
server_slider <- function(id) {
moduleServer(id, function(input, output, session) {
reactive(get(input$slider))
})
}
ui_hist <- function(id, height = 140) {
plotOutput(outputId = NS(id, "hist_plot"), height = height)
}
server_hist <- function(id, df, col, slider_value) {
stopifnot(is.reactive(slider_value))
moduleServer(id, function(input, output, session) {
output$hist_plot <- renderPlot({
df %>%
ggplot(aes_string(x = col)) +
geom_histogram() +
geom_vline(aes(xintercept = slider_value()))
})
})
}
ui <- fluidPage(
titlePanel("My Dashboard"),
sidebarLayout(
sidebarPanel(
ui_hist("gear"),
ui_slider("gear", label = "Gear"),
ui_hist("carb"),
ui_slider("carb", label = "Carb")
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
gear_val <- server_slider("gear")
carb_val <- server_slider("carb")
server_hist(
id = "gear",
df = tibble(mtcars),
col = "gear",
slider_value = gear_val
)
server_hist(
id = "carb",
df = tibble(mtcars),
col = "carb",
slider_value = carb_val
)
output$table <- renderTable({
tibble(mtcars) %>%
filter(gear > gear_val()) %>%
filter(carb > carb_val())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2022-04-22 by the reprex package (v2.0.1)
You're using get() unnecessarily in your slider module server function. Removing it should resolve the issue.
server_slider <- function(id) {
moduleServer(id, function(input, output, session) {
reactive(input$slider)
})
}
Related
I have the following code, which produces a plot based on the user inputs. if, for example, the user selects three x variables, three plots shall be produced in the output. However, at the moment, only the plot relevant to the last selection is only produced.
library(dplyr)
library(ggplot2)
library(shiny)
plt_func <- function(x,y){
plt_list <- list()
for (X_var in x){
plt_list[[X_var]] <- mtcars %>% ggplot(aes(get(X_var), get(y)))+
geom_point() +
labs(x = X_var, y = y)
}
return(plt_list)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(selectizeInput(inputId = "x",label = "X", choices = names(mtcars), multiple = T),
selectInput(inputId = "y",label = "Y", choices = names(mtcars),multiple = F),
actionButton("plot", label = "Plot")),
mainPanel(
plotOutput("finalplot")
)
)
)
server <- function(input, output, session) {
plt <- eventReactive(input$plot, {
req(input$x, input$y)
x <- input$x
y <- input$y
do.call(plt_func, list(x,y))
})
output$finalplot <- renderPlot({
plt()
})
}
shinyApp(ui, server)
Here is a screenshot of the output:
I wonder how I should tackle this issue.
To me, the easiest way to solve this problem is to create a module that will manage a single plot and then create the required number of instances of the module in the main server function. You can read more about Shiny modules here.
A Shiny module consists of two functions, a UI function and a server function. These are paired by the fact that they share a common ID. The ID is used to distinguish different instances of the same module. Namespacing (the ns function) is used to distinguish instances of the same widget in different instances of the module.
The module UI function is straightforward. It simply creates a plotOutput:
plotUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot"))
}
The module server function takes three parameters: an id and the names of the x and y variables to plot.
plotServer <- function(id, Xvar, Yvar) {
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
req(Xvar)
mtcars %>%
ggplot(aes(get(Xvar), get(Yvar))) +
geom_point() +
labs(x = Xvar, y = Yvar)
})
}
)
}
The main UI function creates the sidebar menu (there's no need for a Plot actionButton as Shiny's reactivity makes sure everything gets updated at the correct time) and a main panel that consists only of a uiOutput.
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "x",label = "X", choices = names(mtcars), multiple = T),
selectInput(inputId = "y",label = "Y", choices = names(mtcars), multiple = F)
),
mainPanel(
uiOutput("plotUI")
)
)
)
The main server function is where the magic happens. Every time there's a change to input$x or input$y, new instances of the module UI and server functions are created. One for each selection in input$x. The id for each module is simply an integer. The appropriate column names are passed to each instance of the module server function. A call to renderUI creates the UI for each instance of the module.
server <- function(input, output, session) {
output$plotUI <- renderUI({
ns <- session$ns
tagList(
lapply(1:length(input$x),
function(i) {
plotUI(paste0("plot", i))
}
)
)
})
observeEvent(c(input$x, input$y), {
plotServerList <- lapply(
1:length(input$x),
function(i) {
plotServer(paste0("plot", i), input$x[i], input$y)
}
)
})
}
Putting it all together:
library(dplyr)
library(ggplot2)
library(shiny)
# Plot module UI function
plotUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot"))
}
# Plot module server function
plotServer <- function(id, Xvar, Yvar) {
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
req(Xvar)
mtcars %>%
ggplot(aes(get(Xvar), get(Yvar))) +
geom_point() +
labs(x = Xvar, y = Yvar)
})
}
)
}
# Main UI
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "x",label = "X", choices = names(mtcars), multiple = T),
selectInput(inputId = "y",label = "Y", choices = names(mtcars), multiple = F)
),
mainPanel(
uiOutput("plotUI")
)
)
)
# Main server
server <- function(input, output, session) {
output$plotUI <- renderUI({
ns <- session$ns
tagList(
lapply(1:length(input$x),
function(i) {
plotUI(paste0("plot", i))
}
)
)
})
observeEvent(c(input$x, input$y), {
plotServerList <- lapply(
1:length(input$x),
function(i) {
plotServer(paste0("plot", i), input$x[i], input$y)
}
)
})
}
shinyApp(ui, server)
The goal of this module is create a reactive barplot that changes based on the output of a data selector module. Unfortunately the barplot does not update. It's stuck at the first variable that's selected.
I've tried creating observer functions to update the barplot, to no avail. I've also tried nesting the selector server module within the barplot module, but I get the error: Warning: Error in UseMethod: no applicable method for 'mutate' applied to an object of class "c('reactiveExpr', 'reactive', 'function')"
I just need some way to tell the barplot module to update whenever the data it's fed changes.
Barplot Module:
#UI
barplotUI <- function(id) {
tagList(plotlyOutput(NS(id, "barplot"), height = "300px"))
}
#Server
#' #param data Reactive element from another module: reactive(dplyr::filter(austin_map, var == input$var))
barplotServer <- function(id, data) {
moduleServer(id, function(input, output, session) {
#Data Manipulation
bardata <- reactive({
bar <-
data |>
mutate(
`> 50% People of Color` = if_else(`% people of color` >= 0.5, 1, 0),
`> 50% Low Income` = if_else(`% low-income` >= 0.5, 1, 0)
)
total_av <- mean(bar$value)
poc <- bar |> filter(`> 50% People of Color` == 1)
poc_av <- mean(poc$value)
lowincome <- bar |> filter(`> 50% Low Income` == 1)
lowincome_av <- mean(lowincome$value)
bar_to_plotly <-
data.frame(
y = c(total_av, poc_av, lowincome_av),
x = c("Austin Average",
"> 50% People of Color",
"> 50% Low Income")
)
return(bar_to_plotly)
})
#Plotly Barplot
output$barplot <- renderPlotly({
plot_ly(
x = bardata()$x,
y = bardata()$y,
color = I("#00a65a"),
type = 'bar'
) |>
config(displayModeBar = FALSE)
})
})
}
EDIT :
Data Selector Module
dataInput <- function(id) {
tagList(
pickerInput(
NS(id, "var"),
label = NULL,
width = '100%',
inline = FALSE,
options = list(`actions-box` = TRUE,
size = 10),
choices =list(
"O3",
"Ozone - CAPCOG",
"Percentile for Ozone level in air",
"PM2.5",
"PM2.5 - CAPCOG",
"Percentile for PM2.5 level in air")
)
)
}
dataServer <- function(id) {
moduleServer(id, function(input, output, session) {
austin_map <- readRDS("./data/austin_composite.rds")
austin_map <- as.data.frame(austin_map)
austin_map$value <- as.numeric(austin_map$value)
list(
var = reactive(input$var),
df = reactive(austin_map |> dplyr::filter(var == input$var))
)
})
}
Simplified App
library(shiny)
library(tidyverse)
library(plotly)
source("barplot.r")
source("datamod.r")
ui = fluidPage(
fluidRow(
dataInput("data"),
barplotUI("barplot")
)
)
server <- function(input, output, session) {
data <- dataServer("data")
variable <- data$df
barplotServer("barplot", data = variable())
}
shinyApp(ui, server)
As I wrote in my comment, passing a reactive dataset as an argument to a module server is no different to passing an argument of any other type.
Here's a MWE that illustrates the concept, passing either mtcars or a data frame of random values between a selection module and a display module.
The critical point is that the selection module returns the reactive [data], not the reactive's value [data()] to the main server function and, in turn, the reactive, not the reactive's value is passed as a parameter to the plot module.
library(shiny)
library(ggplot2)
# Select module
selectUI <- function(id) {
ns <- NS(id)
selectInput(ns("select"), "Select a dataset", c("mtcars", "random"))
}
selectServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
if (input$select == "mtcars") {
mtcars
} else {
tibble(x=runif(10), y=rnorm(10), z=rbinom(n=10, size=20, prob=0.3))
}
})
return(data)
}
)
}
# Barplot module
barplotUI <- function(id) {
ns <- NS(id)
tagList(
selectInput(ns("variable"), "Select variable:", choices=c()),
plotOutput(ns("plot"))
)
}
barplotServer <- function(id, plotData) {
moduleServer(
id,
function(input, output, session) {
ns <- NS(id)
observeEvent(plotData(), {
updateSelectInput(
session,
"variable",
choices=names(plotData()),
selected=names(plotData()[1])
)
})
output$plot <- renderPlot({
# There's an irritating transient error as the dataset
# changes, but handling it would
# detract from the purpose of this answer
plotData() %>%
ggplot() + geom_bar(aes_string(x=input$variable))
})
}
)
}
# Main UI
ui <- fluidPage(
selectUI("select"),
barplotUI("plot")
)
# Main server
server <- function(input, output, session) {
selectedData <- selectServer("select")
barplotServer <- barplotServer("plot", plotData=selectedData)
}
# Run the application
shinyApp(ui = ui, server = server)
I'm trying to save and load state of a shiny app using bookmarks. However, it doesn't work and I wonder whether it is because of inserting dynamic UI. If there are other ways to save and load dynamically rendered ui and resulting output, that would be great too. I don't know where to start and this is as far as I could come.
Simple example
library(shiny)
ui <- function(request){fluidPage(
actionButton("add", "Add UI"),
bookmarkButton()
)}
# Server logic
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector = "#add",
where = "afterEnd",
ui = textInput(paste0("txt", input$add),
"Insert some text")
)
})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
Complex example
library(shiny)
one_plotUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot"))
}
one_plot <- function(id, x, y, type, breaks, break_counts) {
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
if (type == "scatter") {
plot(x, y)
} else {
if (breaks == "custom") {
breaks <- break_counts
}
hist(x, breaks = breaks)
}
})
}
)
}
ui <- fluidPage(
sidebarPanel(
bookmarkButton(),
selectInput("plotType", "Plot Type",
c(Scatter = "scatter", Histogram = "hist")
),
# Only show this panel if the plot type is a histogram
conditionalPanel(
condition = "input.plotType == 'hist'",
selectInput(
"breaks", "Breaks",
c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
),
# Only show this panel if Custom is selected
conditionalPanel(
condition = "input.breaks == 'custom'",
sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
)
),
actionButton("make_plot", "Insert new plot")
),
mainPanel(
div(id = "add_here")
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
counter_plots <- 1
observeEvent(input$make_plot, {
current_id <- paste0("plot_", counter_plots)
# call the logic for one plot
one_plot(id = current_id,
x = x,
y = y,
type = input$plotType,
breaks = input$breaks,
break_counts = input$breakCount)
# show the plot
insertUI(selector = "#add_here",
ui = one_plotUI(current_id))
# update the counter
counter_plots <<- counter_plots + 1
})
}
shinyApp(ui, server, enableBookmarking = "server")
edit: Found another solution emulating what insertUI does but with renderUI:
library(shiny)
library(purrr)
ui <- function(request){fluidPage(
actionButton("add", "Add UI"),
uiOutput('dynamic_ui'),
bookmarkButton()
)}
# Server logic
server <- function(input, output, session) {
input_contents <- reactive({reactiveValuesToList(input)})
observeEvent(input$add, {
# a new ui will be rendered with one extra input each time add button is pressed
output$dynamic_ui <- renderUI({
map(1:input$add, ~textInput(inputId = paste0("txt", .x), label = paste0("txt", .x) ))
})
#add the old values, otherwise all the inputs will be empty agin.
input_contents() %>%
names() %>%
map(~ updateTextInput(session = session, inputId = .x, label = .x, value = input_contents()[[.x]]))
})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
insertUI might be broken. The only way i could "fix" it was to drop function(request) of the ui, that caused that all the values in the inputs have to be saved between stances (in state$values$input_restore). Also a warning is showed in the console, but it doesn't affect the functionality.
library(shiny)
library(tidyverse)
library(stringr)
ui <- fluidPage(
actionButton("add", "Add UI"),
uiOutput('restored_ui'), #this is very important
bookmarkButton())
# Server logic
server <- function(input, output, session) {
counter <- reactiveValues()
counter$n <- c(0) #This value is only used to initialize the object.
total_ui_count <- reactiveValues()
total_ui_count$info <- 0 #because input$add will reset to zero this will count the number of uis to remember.
#When bookmark button is pressed
onBookmark(function(state) {
state$values$currentCounter <- counter$n
state$values$input_restore <- reactiveValuesToList(input)
print(names(input) %>% str_subset('^txt'))
state$values$total_uis_to_restore <- counter$n[[length(counter$n)]]
})
#rerender the previous outputs and their values
onRestore(function(state) {
#restore values from previous state
counter$n <- state$values$currentCounter
vals <- state$values$input_restore
print(str_subset(names(vals), '^txt.*$')) #for debugging
total_ui_count$info <- state$values$total_uis_to_restore
print(total_ui_count$info)
#render back a ui with the previous values.
output$restored_ui <- renderUI({
str_subset(names(vals), '^txt.*$') %>%
sort(decreasing = TRUE) %>% #to avoid order reversal of the inputs
map(~ textInput(.x, label = .x, value = vals[[.x]])) #render the last inputs
})
})
observeEvent(input$add, {
#input$add starts as 1 in the next state (because ui is not wrapped in function(request)) that's why total_ui_count is present
counter$n <- c(counter$n, input$add + total_ui_count$info)
print(counter$n) #for debugging
insertUI(
selector = "#add",
where = "afterEnd",
ui = textInput(inputId = paste0("txt", counter$n[[length(counter$n)]]),
label = "Insert some text")
)})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
I have been trying to reconstruct the following simplistic Shiny app using modules since I believe that will be the best way to organize this code inside a much larger application where I will use these kinds of linked-slider-numeric inputs in many places.
However, I cannot figure out how to achieve the same kind of functionality from within a module.
Here's an example app that works exactly as intended, but not using modules:
library(shiny)
# Let's build a linked Slider and Numeric Input
server <- function(input, output) {
values <- reactiveValues(numval=1)
observe({
values$numval <- input$slider
})
observe({
values$numval <- input$number
})
output$slide <- renderUI({
sliderInput(
inputId = 'slider'
,label = 'SN'
,min = 0
,max = 10
,value = values$numval
)})
output$num <- renderUI({
numericInput(
inputId = 'number'
,label = 'SN'
,value = values$numval
,min = 0
,max = 10
)
})
}
ui <- fluidPage(
uiOutput('slide'),
uiOutput('num')
)
shinyApp(ui, server)
Here's my attempt. (Note that "mortalityRate" and associated strings are just an example of the variable name(s) I'll be using later). I have tried several variations on this attempt, but inevitably I get errors, usually indicating I'm doing something that can only be done inside a reactive context:
numericSliderUI <- function(id, label = "Enter value", min = 1, max = 40, value) {
ns <- NS(id)
tagList(
sliderInput(inputId = paste0(ns(id), "Slider"), label = label, min = min, max = max, value = value),
numericInput(inputId = paste0(ns(id), "Numeric"), label = label, min = min, max = max, value = value)
)
}
numericSlider <-
function(input,
output,
session,
value,
mortalityRateSlider,
mortalityRateNumeric
) {
values <- reactiveValues(mortalityRate = value())
observe({
values[['mortalityRate']] <- mortalityRateSlider()
})
observe({
values[['mortalityRate']] <- mortalityRateNumeric()
})
return( reactive( values[['mortalityRate']] ) )
}
library(shiny)
# source("modules.R") # I keep the modules in a separate file, but they're just pasted above for convenience here on StackOverflow.
ui <- fluidPage(
uiOutput('mortalityRate')
)
server <- function(input, output) {
values <- reactiveValues(mortalityRate = 1)
mortalityRateValue <- callModule(
numericSlider,
id = 'mortalityRate',
value = values[['mortalityRate']],
mortalityRateSlider = reactive( input$mortalityRateSlider ),
mortalityRateNumeric = reactive( input$mortalityRateNumeric )
)
values[['mortalityRate']] <- reactive( mortalityRateValue() )
output$mortalityRate <- renderUI(numericSliderUI('mortalityRate', value = values[['mortalityRate']]))
}
shinyApp(ui = ui, server = server)
I know that I must be doing something wrong with the reactiveValues and the way I'm using the observe statements inside the module, but this is my best attempt at using the module structure, so any help figuring out what I'm doing wrong would be very helpful.
Here is working code. There are a variety of changes, so I'll direct you to this Github page that also sets up a structure for using renderUI with modules. In general, I think the problems in your code involved trying to define reactive values inside the callModule function, and in passing the values of the sliders and numeric box back and forth.
Other features of using modules are that in your actual UI call, you need to call the UI module, where in turn you can call uiOutput. Inside renderUI is where you can set up the inputs. Additionally, inside modules you don't need the session namespaces, but you do need to wrap those ids in session$ns() to ensure they work across modules.
UI and Server Modules:
numericSliderUI <- function(id) {
ns <- NS(id)
uiOutput(ns('mortalityRate'))
}
numericSlider <- function(input, output, session) {
values <- reactiveValues(mortalityRate = 1)
observe({
values[['mortalityRate']] <- input$Slider
})
observe({
values[['mortalityRate']] <- input$Numeric
})
output$mortalityRate <- renderUI(
tagList(
sliderInput(inputId = session$ns("Slider"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']]),
numericInput(inputId = session$ns("Numeric"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']])
)
)
return(list(value = reactive({values[['mortalityRate']]})))
}
UI and Server functions:
ui <- fluidPage(
numericSliderUI('mortalityRate')
)
server <- function(input, output, session) {
mortalityRateValue <- callModule(numericSlider, 'mortalityRate')
}
shinyApp(ui = ui, server = server)
Could anyone can tell me why I get an error when I change a dataset in first selectInput widget? When I change a dataset from diamonds to mtcars I get an error Could not find 'carat' in input$bins and in the plot just for one second and after that everything works fine. Why it happened?
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data,
diamonds = diamonds,
mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- data()
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1,
max = max_value,
value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(input$cols) & !is.null(input$bins)) {
basicData <- data()
var <- eval(input$cols)
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
Your respective output objects respond to any changes of your input variables. Thus, when you change your dataset via input$data, the plot rebuilds itself, although input$cols did not yet adjust. Actually, try inserting some print("a") inside the output$plot to see that it is called up to three times if you change input$data.
The fix is to rethink your reaction logic and let your elements respond only to specific changes, to get some kind of response "thread".
For example, input$data should only trigger output$server_cols. And output$server_bins should only be triggered by input$cols (because this already implies that input$data changed earlier). Ultimately, output$plot just has to listen to changes of input$bins (because changes in input$cols and input$data always result in changes of input$bins since it is at the end of the thread).
Here is my suggestion using isolate.
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data, diamonds = diamonds, mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- isolate(data())
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1, max = max_value, value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(isolate(input$cols)) & !is.null(input$bins)) {
basicData <- isolate(data())
var <- eval(isolate(input$cols))
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
You might also want to look into updateSelectInput and updateSliderInput if you want to alter Input Elements depending on other input.