I use a shiny module to plot each element (some data) of a list respectively.
The ui creates some Data (DataPack) (a list with so far two elements) by clicking the "Load"-button. The data is then plotted via the module whereas the x-axis range of each module's plot is controlled by the sliderInput of the ui. In addition, each module plots some "analysis" (a running mean) by clicking the module's "Process" button.
Is there a way, for the ui as well as for the server function, to use insertUI in a way that repeats the module depending on the length of the list DataPack but preserving the connectivity between the ui's slider input with each module (thereby avoiding to copy and paste Module_ui in the ui as well as callModule in the server function several times)?
Thanks!
library(shiny)
library(TTR)
Module_ui <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
column(2, column(12, fluidRow(
numericInput(
inputId = ns("NumericInput_BW"),
label = NULL,
min = 1,
max = 100,
value = 10,
step = 1))),
fluidRow(
column(12, actionButton(
ns("InputButton_ProcessData"), "Process", width = "100%")))),
column(10, plotOutput(ns("Plot"))))
)
}
Module_Server <- function(input, output, session,
DataPack, AnalysedPack,
DataSetName,
InputButton_GetData,
xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData(),
input$InputButton_ProcessData), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <-
runMean(DataPack()[[DataSetName]],
min(input$NumericInput_BW,
length(DataPack()[[DataSetName]])))
return(AnalysedPack)
})
output$Plot <- renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]],
xlim = c(xlim()[1],
xlim()[2]))
lines(AnalysedPack(),
col = "tomato", lwd = 2)
})
}
ui <- fluidPage(
fluidRow(
column(
6,
column(
12,
fluidRow(h4("Data Generation")),
fluidRow(actionButton("InputButton_GetData", "Load", width = "100%")))),
column(
6,
column(
12,
fluidRow(h4("Update Plot")),
sliderInput(
"SliderInput_xAxis",
label = NULL,
min = 0,
max = 150,
value = c(0, 150),
animate = TRUE))
)
),
Module_ui("Plot_1"),
Module_ui("Plot_2")
)
server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("DataPack")
n <- round(runif(1, min = 100, max = 500))
message(n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
updateSliderInput(
session = session,
inputId = "SliderInput_xAxis",
value = c(1, n),
min = 1,
max = n)
return(DataPack)
})
SliderInput_xAxis_rx <- reactive(input$SliderInput_xAxis)
InputButton_GetData_rx <- reactive(input$InputButton_GetData)
callModule(Module_Server, "Plot_1",
DataPack = DataPack,
DataSetName = "one",
InputButton_GetData = InputButton_GetData_rx,
xlim = SliderInput_xAxis_rx)
callModule(Module_Server, "Plot_2",
DataPack = DataPack,
DataSetName = "two",
InputButton_GetData = InputButton_GetData_rx,
xlim = SliderInput_xAxis_rx)
}
shinyApp(ui, server)
Inspired by Thomas Roh's article (Link 1, Link 2) as well as this post it works like this:
library(shiny)
library(TTR)
Module_ui <- function(id) {
ns <- shiny::NS(id)
shiny::uiOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData, xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData(),
input$InputButton_ProcessData), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <-
runMean(DataPack()[[DataSetName]],
min(input$NumericInput_BW,
length(DataPack()[[DataSetName]])))
return(AnalysedPack)
})
output[['Plot']] <- renderUI({
ns <- session$ns
tags$div(
id = environment(ns)[['namespace']],
tagList(
fluidRow(
column(2, column(12, fluidRow(
numericInput(
inputId = ns("NumericInput_BW"),
label = NULL,
min = 1,
max = 100,
value = 10,
step = 1))),
fluidRow(
column(12, actionButton(
ns("InputButton_ProcessData"),
"Process", width = "100%")))),
column(10,
renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]],
xlim = c(xlim()[1],
xlim()[2]))
lines(AnalysedPack(),
col = "tomato", lwd = 2)
}) ) )
)
)
})
}
ui <- fluidPage(
fluidRow(
column(
6,
column(
12,
fluidRow(h4("Data Generation")),
fluidRow(actionButton(
"InputButton_GetData", "Load", width = "100%")))),
column(
6,
column(
12,
fluidRow(h4("Update Plot")),
sliderInput(
"SliderInput_xAxis",
label = NULL,
min = 0,
max = 150,
value = c(0, 150),
animate = TRUE)
)
),
column(12, actionButton('addButton', '', icon = icon('plus')))
)
)
server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("DataPack")
n <- round(runif(1, min = 100, max = 500))
message(n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
updateSliderInput(
session = session,
inputId = "SliderInput_xAxis",
value = c(1, n),
min = 1,
max = n)
return(DataPack)
})
SliderInput_xAxis_rx <-
reactive(input$SliderInput_xAxis)
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
observeEvent(input$InputButton_GetData, {
lapply(names(DataPack()), function(DataSetName) {
id <- sprintf('Plot%s', DataSetName)
insertUI(
selector = "#addButton",
where = "afterEnd",
ui = Module_ui(id)
)
callModule(
Module_Server, id,
DataPack = DataPack,
DataSetName = DataSetName,
InputButton_GetData = InputButton_GetData_rx,
xlim = SliderInput_xAxis_rx)
})
})
}
shinyApp(ui, server)
Related
I need to use renderUI to create multiple input options based on another input value. I want to wrap everything inside renderUI as a function so I can apply this to many similar inputs. Here is a simplified example (which is working for me, but I don't want to repeat the renderUI part many times, because I have many other inputs like the i1):
library(shiny)
ui <- fluidPage(
fluidRow(
selectInput(
inputId = 'i1',
label = 'choice 1',
choices = list(5, 10)
),
uiOutput('o1')
)
)
server <- function(input, output, session) {
output$o1 <- renderUI(
fluidRow(
sliderInput(
inputId = 's1',
label = 'slider 1',
min = 0, max = as.numeric(input$i1) * 10,
value = 0.5
),
sliderInput(
inputId = 's2',
label = 'slider 2',
min = 0, max = as.numeric(input$i1) * 100,
value = 0.5
)
)
)
}
shinyApp(ui = ui, server = server)
The problem is that when I tried to wrap it into a function, the output created by renderUI stops to update when I change the input value. Here is the code that doesn't work for me:
library(shiny)
renderUI_warpper <- function(i){
renderUI(
fluidRow(
sliderInput(
inputId = 's1',
label = 'slider 1',
min = 0, max = as.numeric(i) * 10,
value = 0.5
),
sliderInput(
inputId = 's2',
label = 'slider 2',
min = 0, max = as.numeric(i) * 100,
value = 0.5
)
)
)
}
ui <- fluidPage(
fluidRow(
selectInput(
inputId = 'i1',
label = 'choice 1',
choices = list(5, 10)
),
uiOutput('o1')
)
)
server <- function(input, output, session) {
output$o1 <- renderUI_warpper(input$i1)
}
shinyApp(ui = ui, server = server)
Though I don't see the point to do this because even you move that part to a function, you still have to define each sliderInput, here is one way to do it.
The point is you should wrap the Input instead of renderUI, because you need reactive expressions to be able to update input and reactive only works within another reactive or render* functions
library(shiny)
ui <- fluidPage(
fluidRow(
selectInput(
inputId = 'i1',
label = 'choice 1',
choices = list(5, 10)
),
uiOutput('o1')
)
)
server <- function(input, output, session) {
wrapper <- reactive({
function(i){
fluidRow(
sliderInput(
inputId = 's1',
label = 'slider 1',
min = 0, max = as.numeric(i) * 10,
value = 0.5
),
sliderInput(
inputId = 's2',
label = 'slider 2',
min = 0, max = as.numeric(i) * 100,
value = 0.5
)
)
}
})
output$o1 <- renderUI(wrapper()(input$i1))
}
shinyApp(ui = ui, server = server)
Here is a possible alternative:
library(shiny)
create_sliders <- function(i) {
fluidRow(
column(
width = 12,
sliderInput(
inputId = "s1",
label = "slider 1",
min = 0, max = as.numeric(i) * 10,
value = 0.5
),
sliderInput(
inputId = "s2",
label = "slider 2",
min = 0, max = as.numeric(i) * 100,
value = 0.5
)
)
)
}
ui <- fluidPage(
fluidRow(
selectInput(
inputId = "i1",
label = "choice 1",
choices = list(5, 10)
),
uiOutput("o1")
)
)
server <- function(input, output, session) {
output$o1 <- renderUI({
create_sliders(input$i1)
})
}
shinyApp(ui = ui, server = server)
I'm building a shiny app that has a reactive slider that I want the bar color to be red. I'm trying to use the setSliderColor() function from the shinyWidgets package, but it's not working. My assumption is that it isn't picking up on the sliderId because it isn't:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
setSliderColor(c("green"), sliderId = c(1)),
sidebarLayout(
sidebarPanel(
textInput(inputId = "greeting",
label = "Say hi!"),
actionButton(inputId = "submit",
label = "Submit"),
uiOutput("num_slider"),
),
mainPanel()
))
server <- function(input, output) {
output$num_slider <- renderUI({
shiny::req(input$greeting)
shiny::req(input$submit)
if(input$greeting == "hi!") {
sliderInput(inputId = "num_filter2",
label = "Filter by Number",
min = 1,
max = 10,
value = c(1, 10))
} else {
sliderInput(inputId = "num_filter2",
label = "Filter by Number",
min = 1,
max = 5,
value = c(1, 5))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
But, here's the weird thing. If I put in a regular slider in the UI, it suddenly detects both--but then changes the color back to blue if I click submit twice:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
setSliderColor(c("green", "red"), sliderId = c(1, 2)),
sidebarLayout(
sidebarPanel(
textInput(inputId = "greeting",
label = "Say hi!"),
actionButton(inputId = "submit",
label = "Submit"),
uiOutput("num_slider"),
sliderInput(inputId = "num_filter1",
label = "Now it works!",
min = 1,
max = 10,
value = c(1, 10))
),
mainPanel()
))
server <- function(input, output) {
output$num_slider <- renderUI({
shiny::req(input$greeting)
shiny::req(input$submit)
if(input$greeting == "hi!") {
sliderInput(inputId = "num_filter2",
label = "Filter by Number",
min = 1,
max = 10,
value = c(1, 10))
} else {
sliderInput(inputId = "num_filter2",
label = "Filter by Number",
min = 1,
max = 5,
value = c(1, 5))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Any fix on how address this? I'm also open to other solutions if it avoids long bouts of HTML, like this answer.
The function is just not designed to work with renderUI(). The arguments need to be updated in each call.
a quick fix would be preallocate very large vectors that the user will never reach (like 1 million) or use reactiveValues() like this:
note: The sliders will turn green when "hi!" is passed as an input.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
textInput(inputId = "greeting",
label = "Say hi!"),
actionButton(inputId = "submit",
label = "Submit"),
uiOutput("num_slider"),
sliderInput(inputId = "num_filter1",
label = "Now it works!",
min = 1,
max = 10,
value = c(1, 10))
),
mainPanel()
))
server <- function(input, output) {
i <- reactiveValues()
i$color <- 1
i$color_name <- 'green'
observeEvent(input$submit, {
i$color <- c(i$color, i$color[[length(i$color)]] + 1)
i$color_name <- c(i$color_name, 'green')
#left for demonstration purposes
print(i$color)
print(i$color_name)
shiny::req(input$greeting)
shiny::req(input$submit)
output$num_slider <- renderUI({
if(input$greeting == "hi!") {
fluidPage(setSliderColor(i$color_name, sliderId = i$color),
sliderInput(inputId = "num_filter2",
label = "Filter by Number",
min = 1,
max = 10,
value = c(1, 10)))}
}) })
}
# Run the application
shinyApp(ui = ui, server = server)
I'm trying to call a module from inside a module and having some problems.
This first code is working, it displays an app with a button that creates a popup. Inside the popup is a plot and a slider input. The popup-plot is defined in it's own module.
library(shiny)
library(shinyWidgets)
uiForModal <<- function(id) {
ns <- NS(id)
tagList(
fluidRow(
plotOutput(outputId = ns("plot")),
sliderInput(
inputId =ns( "clusters"),
label = "Number of clusters",
min = 2, max = 6, value = 3, width = "100%"
)
)
)
}
serverForModal <<- function(input, output, session) {
output$plot <- renderPlot({
print(head(iris))
plot(Sepal.Width ~ Sepal.Length,
data = iris, col = Species,
pch = 20, cex = 2)
points(kmeans(iris[, 1:2], input$clusters)$centers,
pch = 4, cex = 4, lwd = 4)
})
}
ui <- fluidPage(
actionButton("showPlot", "showPlot")
)
server <- function(input, output){
observeEvent(input$showPlot, {
show_alert(
title = "Some Title",
text = tags$div(
uiForModal("test1")
),
html = TRUE,
width = "80%"
)
})
callModule(serverForModal, "test1")
}
runApp(shinyApp(ui, server))
The problem occurs when I try to put the button inside its own module. The code below is my failed attempt at this. I think the problem is something to do with the namespace. In the code below, the button calls the UI with the popup and slider, but the plot doesn't show. So I think the problem is in the server namespace for the plot. Can someone please help me out?
library(shiny)
library(shinyWidgets)
uiForModal <<- function(id) {
print(id)
ns <- NS(id)
print(ns("plot"))
tagList(
fluidRow(
plotOutput(outputId = ns("plot")),
sliderInput(
inputId =ns( "clusters"),
label = "Number of clusters",
min = 2, max = 6, value = 3, width = "100%"
)
)
)
}
serverForModal <<- function(input, output, session) {
output$plot <- renderPlot({
print(head(iris))
plot(Sepal.Width ~ Sepal.Length,
data = iris, col = Species,
pch = 20, cex = 2)
points(kmeans(iris[, 1:2], input$clusters)$centers,
pch = 4, cex = 4, lwd = 4)
})
}
uiForButton <<- function(id) {
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("showPlot"), "showPlot")
)
)
}
serverForButton <<- function(input, output, session, ns) {
observeEvent(input$showPlot, {
show_alert(
title = "Some Title",
text = tags$div(
uiForModal(ns("test2"))
),
html = TRUE,
width = "80%"
)
})
callModule(serverForModal, ns("test2"))
}
ui <- fluidPage(
uiForButton("test1")
)
server <- function(input, output){
callModule(serverForButton, "test1", NS("test1"))
}
runApp(shinyApp(ui, server))
Change
callModule(serverForModal, ns("test2"))
to
callModule(serverForModal, "test2")
I created a (for demonstration purposes reproducible) shiny app where the ui creates some Data (DataPack) (a list with two elements) by clicking the "Load"-button. Every element of this list is plotted via the module using lapply in the server function.
The app works, however, the plots come out in reverse order (DataPack$two with rnorm(n)^2 before DataPack$one with rnorm(n)) but are expected to be shown as called (lapply(names(DataPack()), function(DataSetName) {...})). How do I fix this/repeat calling modules in an exactly given order and what is the explanation for that behavior?
library(shiny)
library(TTR)
Module_ui <- function(id) {
ns <- shiny::NS(id)
shiny::uiOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData, xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData(),
input$InputButton_ProcessData), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <-
runMean(DataPack()[[DataSetName]],
min(input$NumericInput_BW,
length(DataPack()[[DataSetName]])))
return(AnalysedPack)
})
output[['Plot']] <- renderUI({
ns <- session$ns
tags$div(
id = environment(ns)[['namespace']],
tagList(
fluidRow(
column(2, column(12, fluidRow(
numericInput(
inputId = ns("NumericInput_BW"),
label = NULL,
min = 1,
max = 100,
value = 10,
step = 1))),
fluidRow(
column(12, actionButton(
ns("InputButton_ProcessData"),
"Process", width = "100%")))),
column(10,
renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]],
xlim = c(xlim()[1],
xlim()[2]))
lines(AnalysedPack(),
col = "tomato", lwd = 2)
}) ) )
)
)
})
}
ui <- fluidPage(
fluidRow(
column(
6,
column(
12,
fluidRow(h4("Data Generation")),
fluidRow(actionButton(
"InputButton_GetData", "Load", width = "100%")))),
column(
6,
column(
12,
fluidRow(h4("Update Plot")),
sliderInput(
"SliderInput_xAxis",
label = NULL,
min = 0,
max = 150,
value = c(0, 150),
animate = TRUE)
)
),
column(12, actionButton('addButton', '', icon = icon('plus')))
)
)
server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("DataPack")
n <- round(runif(1, min = 100, max = 500))
message(n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
updateSliderInput(
session = session,
inputId = "SliderInput_xAxis",
value = c(1, n),
min = 1,
max = n)
return(DataPack)
})
SliderInput_xAxis_rx <-
reactive(input$SliderInput_xAxis)
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
observeEvent(input$InputButton_GetData, {
lapply(names(DataPack()), function(DataSetName) {
id <- sprintf('Plot%s', DataSetName)
insertUI(
selector = "#addButton",
where = "afterEnd",
ui = Module_ui(id)
)
callModule(
Module_Server, id,
DataPack = DataPack,
DataSetName = DataSetName,
InputButton_GetData = InputButton_GetData_rx,
xlim = SliderInput_xAxis_rx)
})
})
}
shinyApp(ui, server)
This code:
insertUI(
selector = "#addButton",
where = "afterEnd",
ui = Module_ui(id)
)
inserts the UI after the element #addButton. So the first call generates, schematically:
#addButton
ui1
And the second call, as the first one, inserts after #addButton, not after ui1:
#addButton
ui2
ui1
So, reverse the names.
I have a shinydashboard app with two different tab panels. Each tab has different input values and both of them generate a graph when an action button is clicked.
Whenever I switch between these tabs, their respective graphs disappear and input values are reset to default.
I want to keep the tabs in their user modified states (i.e keep both graphs and inputs) even when the user decides to switch between the panels.
Code
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
uiOutput("mysidebar"),
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", fluid = TRUE, value = 1,plotOutput("A")),
tabPanel("Tab2", fluid = TRUE, value = 2, plotOutput("B"))
)
)
)
)
server <- function(input, output, session){
output$mysidebar <- renderUI({
if(input$tab == 1){
tagList(
sliderInput(inputId = "Sample",
label = "Enter Number of Samples:",
min = 1000, max = 100000,
value = 10000),
fluidRow(
column(6,
actionButton(inputId = "b1", label = "Generate"))
)}
if(input$tab == 2){
tagList(
sliderInput(inputId = "Weight",
label = "Enter Weight:",
value = 100),
fluidRow(
column(6,
actionButton(inputId = "b2", label = "Generate"))
)}
p1<- eventReactive(input$b1, {
#creating a dataframe using input "Sample" in tab1 - Rough example
df <- input$Sample
})
output$SA <- renderPlot({
plot(df)
})
p2 <- eventReactive(input$b2, {
#creating a dataframe using input "Weight" in tab2-- Rough example
df2 <- input$Weight
})
output$A <- renderPlot({
plot(p1())
})
output$B <- renderPlot({
plot(p2())
})
}
I'd much rather you use show and hide functionality within shinyjs package like example below, this way the values will be preserved when you switch between the Tabs
library(shiny)
library(shinyjs)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
useShinyjs(),
sliderInput("Sample","Enter Number of Samples:",min = 1000, max = 100000,value = 10000),
sliderInput("Weight","Enter Weight:",min = 1, max = 1000,value = 100),
fluidRow(column(6,actionButton("b1","Generate"),actionButton("b2","Generate")))
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", fluid = TRUE, value = 1,plotOutput("A")),
tabPanel("Tab2", fluid = TRUE, value = 2, plotOutput("B"))
)
)
)
)
server <- function(input, output, session){
observe({
if(input$tab == 1){
show("Sample")
show("b1")
hide("Weight")
hide("b2")
}
if(input$tab == 2){
hide("Sample")
hide("b1")
show("Weight")
show("b2")
}
})
p1<- eventReactive(input$b1,{
df <- rnorm(input$Sample)
})
output$SA <- renderPlot({
plot(df)
})
p2 <- eventReactive(input$b2,{
df2 <- rnorm(input$Weight)
})
output$A <- renderPlot({plot(p1())})
output$B <- renderPlot({plot(p2())})
}
shinyApp(ui, server)
The following code keeps the plots and inputs, by using reactiveValues.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = "DASHBOARD"),
dashboardSidebar(
uiOutput("mysidebar")
),
dashboardBody(
tabsetPanel(type = "tabs", id = "tab",
tabPanel("Tab1", value = 1,plotOutput("SA")),
tabPanel("Tab2", value = 2, plotOutput("SA1"))
)
)
)
server <- function(input, output, session){
slider_react <- reactiveValues(b1=10000, b2 = 100)
observe({
if (input$tab == 1){
output$mysidebar <- renderUI({
tagList(
sliderInput(inputId = "Sample",
label = "Enter Number of Samples:",
min = 1000, max = 100000,
# value = 10000),
value = slider_react$b1),
actionButton(inputId = "b1", label = "Generate"))
})
}
if(input$tab == 2){
output$mysidebar <- renderUI({
tagList(
sliderInput(inputId = "Weight",
label = "Enter Weight:",
min=0, max=1000,
# value = 100),
value = slider_react$b2),
actionButton(inputId = "b2", label = "Generate"))
})
}
})
df_react <- reactiveValues(a1=NULL, a2=NULL)
p1<- observeEvent(input$b1, {
#creating a dataframe using input "Sample" in tab1 - Rough example
df <- runif(input$Sample, 0, 100)
slider_react$b1 = input$Sample
df_react$a1 = df
})
p2 <- observeEvent(input$b2, {
#creating a dataframe using input "Weight" in tab2-- Rough example
df2 <- runif(input$Weight, 0, 100)
slider_react$b2 = input$Weight
df_react$a2 = df2
})
output$SA <- renderPlot({
req(df_react$a1)
plot(df_react$a1)
})
output$SA1 <- renderPlot({
req(df_react$a2)
plot(df_react$a2)
})
}
shinyApp(ui, server)