I am trying to create a dynamic UI that has variable number of user inputs based on a user input and charts that uses that second level of user input.
A working example below:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
c_count = reactive({input$Chartcount})
output$distui <- renderUI({
lapply(seq(1:c_count()), function(x){
chartId = (paste("Chart",x, sep = "="))
sinput <- sliderInput(inputId = paste(x,"_bins"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
selectedbins = input[[paste(x,"_bins")]] # input$inputId does not work here as expression after $ can not be evaluated
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = 25 ) #I want to use selectedbins here for length.out
distplot <- renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
list(chartId, sinput,selectedbins, distplot)
})
})
}
shinyApp(ui = ui, server = server)
I think there are at least a couple of problems with this.
Selected number of bins resets as soon as they are selected
I get an error when I try to use selectedbins in the chart for
length.out
bins <- seq(min(x), max(x), length.out = selectedbins ) # This throws an error Error: argument 'length.out' must be of length 1
The selected number of bins is resetting because it is inside of the same reactive expression, you should put it in a different reactive expression, otherwise the full expression is going to be executed every time you change the input and it is going to recreate all the inputs and plots.
The second problem is caused because you are trying to use the selectedbins input value before the slider is created, therefore the value is NULL (length 0), you can only get the value after the slider is created.
Below is your code modified to create the plots in a separated reactive expression as a nested expression, maybe not the best solution but it is in the same style that your program. Also, reusing the x variable is confusing, so I changed the first one by k.
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
output$distui <- renderUI({
lapply(seq(1:input$Chartcount), function(k){
chartId = (paste("Chart", k, sep = "="))
sinput <- sliderInput(inputId = paste(k, "bins_"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
x <- faithful[, 2]
distplot <- tagList(
renderUI({
selectedbins = input[[paste(k, "bins_")]]
bins <- seq(min(x), max(x), length.out = selectedbins )
tagList(
selectedbins,
renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
)
})
)
list(chartId, sinput, distplot)
})
})
}
shinyApp(ui = ui, server = server)
Related
My app should follow this logic: If an action button is pressed, all inputs are disabled and a long computation is performed. When the computation is finished and its results are plotted, all inputs except for the action button become enabled again. If the user decides to change one input, the action button becomes enabled.
Most of this desired behaviour is working, except for the last bit, the enabling of the action button. Here is my server function (the action button is named "go"):
server <- function(input, output, session) {
allinputIds <- reactive(names(input))
shiny::observeEvent(input$go, {
for (id in allinputIds()) shinyjs::disable(id)
})
# ==> here is some trouble: not working
shiny::observeEvent(allinputIds(), shinyjs::enable("go"))
# from here starts the real work
bins <- shiny::eventReactive(input$go, {
x <- faithful$waiting
Sys.sleep(1.5)
seq(min(x), max(x), length.out = input$bins + 1)
})
output$figure <- shiny::renderPlot({
x <- faithful$waiting
hist(
x, breaks = bins(), col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times"
)
for (id in setdiff(allinputIds(), "go")) shinyjs::enable(id)
})
}
How can I observe that any input has been changed? Instead of allinputIds() after the line marked "==>", I tried input but this worked neither.
As a second question, what would you recommend to encapsulate this button / disable / enable pattern, which I plan to use on more than one shiny module. It would be nice if I could concentrate on the main code, i.e. bins and output$figure <- ....
Any hint appreciated!
For reproducibility, here is the ui function:
ui <- shiny::tagList(
shinyjs::useShinyjs(),
shiny::navbarPage(title="Test 2",
tabPanel(title="Old Faithful",
shiny::sidebarLayout(
shiny::sidebarPanel(
shiny::sliderInput(
inputId = "bins",
label = "Number of bins:",
min = 1,
max = 50,
value = 30
)
),
shiny::mainPanel(
shiny::actionButton("go", "Update"),
shinycssloaders::withSpinner(plotOutput(outputId="figure")),
shiny::h4(shiny::textOutput("msg"))
)
)
)
)
)
shiny::shinyApp(ui, server)
The problem is that in shiny::observeEvent(allinputIds(), shinyjs::enable("go")) you just check if the names/amount of input ids change - they don't. You actually need to check if the values of any of the inputs (besides the action button) has changed. Therefore you can either put all inputs directly into the observe like c(input$bins, input$...) or make an extra reactive to check for the values and just call this reactive.
library(shiny)
server <- function(input, output, session) {
allinputIds <- reactive(names(input))
changingInputValues <- reactive({
checkIds <- setdiff(names(input), "go")
lapply(checkIds, function(x) input[[x]])
})
observeEvent(input$go, {
lapply(allinputIds(), shinyjs::disable)
})
# ==> here is some trouble: not working
observeEvent(changingInputValues(), shinyjs::enable("go"))
# from here starts the real work
bins <- eventReactive(input$go, {
x <- faithful$waiting
Sys.sleep(1.5)
seq(min(x), max(x), length.out = input$bins + 1)
})
output$figure <- renderPlot({
x <- faithful$waiting
hist(
x, breaks = bins(), col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times"
)
lapply(setdiff(allinputIds(), "go"), shinyjs::enable)
})
}
ui <- tagList(
shinyjs::useShinyjs(),
navbarPage(title="Test 2",
tabPanel(title="Old Faithful",
sidebarLayout(
sidebarPanel(
sliderInput(
inputId = "bins",
label = "Number of bins:",
min = 1,
max = 50,
value = 30
)
),
mainPanel(
actionButton("go", "Update"),
shinycssloaders::withSpinner(plotOutput(outputId="figure")),
h4(textOutput("msg"))
)
)
)
)
)
shinyApp(ui, server)
Note that I've changed the for loops to lapply, as for loops tend to not work well with shiny (unfortunately, I'm not sure why). A few times the enabling of the inputs didn't work when using the loop, but with lapply I haven't had any problems.
Friends could help me make my conditionalPanel functional. I made a conditionalPanel however I don't know how to adjust it on the server. When I press the option "No" I would like it to show the sliderInput ("Slider2"). The executable code is below. Thank you!
library(shiny)
ui <- shiny::navbarPage(
title = div(tags$img(src="", align="right", height='50px')),
sidebarLayout(
sidebarPanel(
sliderInput("Slider1",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
sidebarLayout(
sidebarPanel(
radioButtons("filter1","", choices = list("Yes" = 1,"No " = 2),selected = 1),
conditionalPanel(
"input.filter1 == 'No'",
sliderInput("Slider2",
"Number of bins:",
min = 1,
max = 20,
value = 30)),
),
mainPanel(
plotOutput("distPlot1")
))))
server <- function(input, output) {
output$distPlot1 <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$Slider1 + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
When you do
radioButtons("filter1", "", choices = list("Yes" = 1,"No " = 2)
the values of the radio buttons are "1" and "2", while "Yes" and "No" are the labels of the radio buttons. So you condition should be "input.filter1 == '2'".
Your condition must be "input.filter1 == 2" and not "input.filter1 == 'No'".
"No" is the name of the element, while 2 is the value (that is evaluated).
It will work with this modification.
I have two numericInput boxes, allowing for the input of the min and max (range) of a numeric variable. I have tried using splitLayout, which works but the boxes are misaligned when I include a label for the boxes.
The code is below
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
#fluidRow(
splitLayout(
variable <- faithful$waiting,
numericInput(paste("Min"),
#round = TRUE,
label = h5(c("test")),
min = round(min(variable, na.rm=TRUE)),
max = round(max(variable, na.rm=TRUE))-1,
value = round(min(variable, na.rm=TRUE))
), ## end slider input
numericInput(paste("Min"),
#round = TRUE,
label = h5(""),
min = round(min(variable, na.rm=TRUE))+1,
max = round(max(variable, na.rm=TRUE)),
value = round(max(variable, na.rm=TRUE))
)
)
)
))
# Define server logic required to draw a histogram
server <- function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
If you run the code, you will see that the boxes are misaligned.
How can I fix this?
The issue is that you have a label for one box, which pushes it down, with no equivalent label for the other box. To push the second box down, you need to include something that will read as label without showing anything. I used an HTML break:
numericInput(paste("Min"),
#round = TRUE,
label = h5(HTML("<br/>")),
min = round(min(variable, na.rm=TRUE))+1,
max = round(max(variable, na.rm=TRUE)),
value = round(max(variable, na.rm=TRUE))
I want the app to load a single time with default values, but become reactive only when the user types the correct password. To keep things simple let's work from the Rstudio template (minutely edited):
ui.R:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
output$histo <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
There are two reactive inputs pw and nbins. My question is: How could the code be extended to make nbins (behavior) switch between reactive and non-reactive depending on the input pw being equal to PASSWORD?
Building on Valter's answer, you can use shinyjs to enable/disable interactivity with the input widget.
ui.R
library(shiny)
library(shinyjs) # install shinyjs
shinyUI(fluidPage(
useShinyjs(), # activate
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R
library(shiny)
library(shinyjs)
shinyServer(function(input, output) {
observe({
if(input$pw != "PASSWORD") shinyjs::hide("nbins") else shinyjs::show("nbins")
})
output$histo <- renderPlot({
x <- faithful[, 2]
# will 'reset' bins to original value if incorrect pw
if(input$pw != "PASSWORD") {
bins <- seq(min(x), max(x), length.out = 30 + 1)
} else {
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
}
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
What about this solution:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
bins <- eventReactive(input$nbins, {
if (input$pw == PASSWORD) {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = input$nbins + 1)
} else {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = 30 + 1)
}
})
output$histo <- renderPlot({
x <- faithful[, 2]
hist(x, breaks = bins(), col = 'darkgray', border = 'white')
})
})
I use the library shinythemes pretty extensively in apps that I build. I was trying to leverage a bsModal from the shinyBS package and noticed that the 'fade in' div never went away leaving me with an unusable web app since nothing was clickable.
The examples from shinyBS::bsModal all work fine (they are sans-shinythemes). How can I continue to use themes while also using modals?
Example App:
library(shiny)
library(shinyBS)
library(shinythemes)
app = shinyApp(
ui =
navbarPage(title=NULL,
id="navbar",
theme = shinytheme("journal"),
tabPanel("test",
column(1),
column(3,
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("tabBut", "View Table")
),
column(7,
plotOutput("distPlot"),
bsModal("modalExample", "Data Table", "tabBut", size = "large",
dataTableOutput("distTable"))
)
)
),
server =
function(input, output, session) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distTable <- renderDataTable({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
tab <- hist(x, breaks = bins, plot = FALSE)
tab$breaks <- sapply(seq(length(tab$breaks) - 1), function(i) {
paste0(signif(tab$breaks[i], 3), "-", signif(tab$breaks[i+1], 3))
})
tab <- as.data.frame(do.call(cbind, tab))
colnames(tab) <- c("Bins", "Counts", "Density")
return(tab[, 1:3])
}, options = list(pageLength=10))
}
)
runApp(app)
I don't know what causes the conflict, but the solution is to specify the link to the theme directly. Replace theme = shinytheme("journal") with theme = "http://bootswatch.com/journal/bootstrap.css" adjusting the name for the theme you're using.