Updating pickerInput based on radiobutton - r

I want to be able to update the selection available in the pickerInput based upon the selection made in the radio button input. In the example below, I want the radio button "A", to give a pickerInput list of mtcars$cyl, whilst a picker input of "B" to give a picker input of mtcars$mpg
I have tried doing this using if statements, but I haven't got anywhere so far. Reproducible example below:
library(shiny)
library(leaflet)
library(shinyjs)
library(rgeos)
library(tidyverse)
library(openxlsx)
library(plotly)
library(shinyWidgets)
library(rgdal)
ui <- fluidPage(shinyjs::useShinyjs(),
fluidRow(column(
6,radioButtons("type", "Type:",
c("A" = "norm",
"B" = "unif")))),
fluidRow(column(
3,
pickerInput("regInput","Region",choices=unique(mtcars$cyl),
options = list(`actions-box` = TRUE),multiple = T,
selected = unique(mtcars$cyl)))))
server <- function (input, output, session) {
observeEvent(input$type,{
a_option <- input$regInput
if (a_option == "B") {
updatePickerInput(session = session,inputId = "regInput",
choices =unique(mtcars$mpg))}})
}
shinyApp(ui = ui, server = server)

As said in the other answer you need to observe input$type and update the picker input according to the values in it. Also, it's important to include an else statement, to be able to update the picker input when the user picks between the radio button choices multiple times. Finally, on the updatePickerInput you need to include the selected argument to maintain the behaviour as it is on the ui.
Here's the code doing what I've described above:
library(shiny)
library(shinyjs)
library(tidyverse)
library(shinyWidgets)
ui <- fluidPage(shinyjs::useShinyjs(),
fluidRow(
column(
6,
radioButtons("type",
"Type:",
c("A" = "norm",
"B" = "unif"))
)),
fluidRow(
column(
3,
pickerInput("regInput","Region",
choices=unique(mtcars$cyl),
options = list(`actions-box` = TRUE),
multiple = T,
selected = unique(mtcars$cyl))
))
)
server <- function (input, output, session) {
observeEvent(input$type,{
if (input$type == "unif") {
updatePickerInput(session = session,inputId = "regInput",
choices = unique(mtcars$mpg),
selected = unique(mtcars$mpg))
} else {
updatePickerInput(session = session,inputId = "regInput",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl))
}
})
}
shinyApp(ui = ui, server = server)

The server has to listen to the right UI Element (ID = "type" for the radio buttons in question). Currently it observes an undefined element "dist".
Try changing
observeEvent(input$dist, { code })
to
observeEvent(input$type, { code })

Related

How to add a spinner before a selectizeInput has loaded all the choices? [Shiny]

I want to make an app with 2 actionButtons: 1) to submit the changes before loading a selectizeInput and 2) to draw the plot.
I know how to add a spinner after clicking a actionButton but the majority of the cases is added when you want to show the plot.
However, is it possible to add a spinner without showing any plot?
In this particular case, I want to show a spinner after clicking "Submit" until the selectizeInput from the 'Selection tab' is loaded. As you can see the example that I attach, it takes a bit to load all the choices (since the file has 25000 rows).
I already have one spinner after clicking the second actionButton (Show the plot) but I need one more.
I have created an example, but for some reason the plot is not shown in the shiny app and it appears in the window from R (I don't know why but I added the plot just to show you how I put the second spinner. I want a similar one but with the first actionButton.).
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
titlePanel("My app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Submit",
checkboxInput("log2", "Log2 transformation", value = FALSE),
actionButton("submit", "Submit")
),
tabPanel("Selection",
br(),
selectizeInput(inputId = "numbers", label = "Choose one number:", choices=character(0)),
actionButton("show_plot", "Show the plot")
))
),
mainPanel(
conditionalPanel(
condition = "input.show_plot > 0",
style = "display: none;",
withSpinner( plotOutput("hist"),
type = 5, color = "#0dc5c1", size = 1))
)
)
)
server <- function(input, output, session) {
data <- reactive({
data = read.csv("https://people.sc.fsu.edu/~jburkardt/data/csv/hw_25000.csv")
data[,1] <- as.character(data[,1])
if(input$log2 == TRUE){
cols <- sapply(data, is.numeric)
data[cols] <- lapply(data[cols], function(x) log2(x+1))
}
return(data)
})
mylist <- reactive({
req(data())
data <- data()
data <- data[,1]
return(data)
})
# This is to generate the choices (gene list) depending on the user's input.
observeEvent(input$submit, {
updateSelectizeInput(
session = session,
inputId = "numbers",
choices = mylist(), options=list(maxOptions = length(mylist()))
)
})
v <- reactiveValues()
observeEvent(input$show_plot, {
data <- data()
v$plot <- plot(x=data[,1], y=data[,2])
})
# If the user didn't choose to see the plot, it won't appear.
output$hist <- renderPlot({
req(data())
if (is.null(v$plot)) return()
if(input$show_plot > 0){
v$plot
}
})
}
Does anyone know how to help me, please?
Thanks very much
It's a little tricky.
First of all I'd update the selectizeInput on the server side as the warning suggests:
Warning: The select input "numbers" contains a large number of
options; consider using server-side selectize for massively improved
performance. See the Details section of the ?selectizeInput help
topic.
Furthermore I switched to ggplot2 regarding the plotOutput - Please see this related post.
To show the spinner while the selectizeInput is updating choices we'll need to know how long the update takes. This information can be gathered via shiny's JS events - please also see this article.
Finally, we can show the spinner for a non-existent output, so we are able to control for how long the spinner is shown (see uiOutput("dummyid")):
library(shiny)
library(shinycssloaders)
library(ggplot2)
ui <- fluidPage(
titlePanel("My app"),
tags$script(HTML(
"
$(document).on('shiny:inputchanged', function(event) {
if (event.target.id === 'numbers') {
Shiny.setInputValue('selectizeupdate', true, {priority: 'event'});
}
});
$(document).on('shiny:updateinput', function(event) {
if (event.target.id === 'numbers') {
Shiny.setInputValue('selectizeupdate', false, {priority: 'event'});
}
});
"
)),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Submit",
checkboxInput("log2", "Log2 transformation", value = FALSE),
actionButton("submit", "Submit")
),
tabPanel("Selection",
br(),
selectizeInput(inputId = "numbers", label = "Choose one number:", choices=NULL),
actionButton("show_plot", "Show the plot")
))
),
mainPanel(
uiOutput("plotProxy")
)
)
)
server <- function(input, output, session) {
previousEvent <- reactiveVal(FALSE)
choicesReady <- reactiveVal(FALSE)
submittingData <- reactiveVal(FALSE)
observeEvent(input$selectizeupdate, {
if(previousEvent() && input$selectizeupdate){
choicesReady(TRUE)
submittingData(FALSE)
} else {
choicesReady(FALSE)
}
previousEvent(input$selectizeupdate)
})
data <- reactive({
data = read.csv("https://people.sc.fsu.edu/~jburkardt/data/csv/hw_25000.csv")
if(input$log2 == TRUE){
cols <- sapply(data, is.numeric)
data[cols] <- lapply(data[cols], function(x) log2(x+1))
}
return(data)
})
mylist <- reactive({
req(data()[,1])
})
observeEvent(input$submit, {
submittingData(TRUE)
reactivePlotObject(NULL) # reset
updateSelectizeInput(
session = session,
inputId = "numbers",
choices = mylist(), options=list(maxOptions = length(mylist())),
server = TRUE
)
})
reactivePlotObject <- reactiveVal(NULL)
observeEvent(input$show_plot, {
reactivePlotObject(ggplot(data(), aes_string(x = names(data())[1], y = names(data())[2])) + geom_point())
})
output$hist <- renderPlot({
reactivePlotObject()
})
output$plotProxy <- renderUI({
if(submittingData() && !choicesReady()){
withSpinner(uiOutput("dummyid"), type = 5, color = "#0dc5c1", size = 1)
} else {
conditionalPanel(condition = "input.show_plot > 0", withSpinner(plotOutput("hist"), type = 5, color = "#0dc5c1", size = 1), style = "display: none;")
}
})
}
shinyApp(ui, server)
First 100 rows of your example data (dput(head(data, 100)) - your link might be offline some day):
structure(list(Index = 1:100, Height.Inches. = c(65.78331, 71.51521,
69.39874, 68.2166, 67.78781, 68.69784, 69.80204, 70.01472, 67.90265,
66.78236, 66.48769, 67.62333, 68.30248, 67.11656, 68.27967, 71.0916,
66.461, 68.64927, 71.23033, 67.13118, 67.83379, 68.87881, 63.48115,
68.42187, 67.62804, 67.20864, 70.84235, 67.49434, 66.53401, 65.44098,
69.5233, 65.8132, 67.8163, 70.59505, 71.80484, 69.20613, 66.80368,
67.65893, 67.80701, 64.04535, 68.57463, 65.18357, 69.65814, 67.96731,
65.98088, 68.67249, 66.88088, 67.69868, 69.82117, 69.08817, 69.91479,
67.33182, 70.26939, 69.10344, 65.38356, 70.18447, 70.40617, 66.54376,
66.36418, 67.537, 66.50418, 68.99958, 68.30355, 67.01255, 70.80592,
68.21951, 69.05914, 67.73103, 67.21568, 67.36763, 65.27033, 70.84278,
69.92442, 64.28508, 68.2452, 66.35708, 68.36275, 65.4769, 69.71947,
67.72554, 68.63941, 66.78405, 70.05147, 66.27848, 69.20198, 69.13481,
67.36436, 70.09297, 70.1766, 68.22556, 68.12932, 70.24256, 71.48752,
69.20477, 70.06306, 70.55703, 66.28644, 63.42577, 66.76711, 68.88741
), Weight.Pounds. = c(112.9925, 136.4873, 153.0269, 142.3354,
144.2971, 123.3024, 141.4947, 136.4623, 112.3723, 120.6672, 127.4516,
114.143, 125.6107, 122.4618, 116.0866, 139.9975, 129.5023, 142.9733,
137.9025, 124.0449, 141.2807, 143.5392, 97.90191, 129.5027, 141.8501,
129.7244, 142.4235, 131.5502, 108.3324, 113.8922, 103.3016, 120.7536,
125.7886, 136.2225, 140.1015, 128.7487, 141.7994, 121.2319, 131.3478,
106.7115, 124.3598, 124.8591, 139.6711, 137.3696, 106.4499, 128.7639,
145.6837, 116.819, 143.6215, 134.9325, 147.0219, 126.3285, 125.4839,
115.7084, 123.4892, 147.8926, 155.8987, 128.0742, 119.3701, 133.8148,
128.7325, 137.5453, 129.7604, 128.824, 135.3165, 109.6113, 142.4684,
132.749, 103.5275, 124.7299, 129.3137, 134.0175, 140.3969, 102.8351,
128.5214, 120.2991, 138.6036, 132.9574, 115.6233, 122.524, 134.6254,
121.8986, 155.3767, 128.9418, 129.1013, 139.4733, 140.8901, 131.5916,
121.1232, 131.5127, 136.5479, 141.4896, 140.6104, 112.1413, 133.457,
131.8001, 120.0285, 123.0972, 128.1432, 115.4759)), row.names = c(NA,
100L), class = "data.frame")

selectizeInput: allowing one element per group

I have a selectizeInput with some grouped elements with multiple selection. Is there an elegant way (e.g. using the options argument) of allowing just one element per group, so that a whole group will discarded (or disabled) when an element of this specific group is selected?
So far I tried it programmatically, but than the dropdown menu of the selectizeInput will be closed when updating the selectizeInput.
Minimal example:
library(shiny)
ui <- fluidPage(
selectizeInput("selInput", "Default",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T),
selectizeInput("oneElementPerGroup", "One element per group",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T)
)
server <- function(session, input, output) {
#Removes the corresponding groups of selected items
observeEvent(input$oneElementPerGroup, ignoreNULL = F, {
plusChoice <- input$oneElementPerGroup
names(plusChoice) <- input$oneElementPerGroup
choices <- list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D"))
if(any(input$oneElementPerGroup %in% c("A", "B"))){
choices[["g1"]] <- NULL
}
if(any(input$oneElementPerGroup %in% c("C", "D"))){
choices[["g2"]] <- NULL
}
choices$we <- plusChoice
updateSelectizeInput(session,"oneElementPerGroup",
choices = choices,
selected=input$oneElementPerGroup)
})
}
shinyApp(ui = ui, server = server)
You can use pickerInput from {shinyWidgets}. Then we can add a little javascript to do what you want. No server code is needed, very simple. Read more about the data-max-options option: https://developer.snapappointments.com/bootstrap-select/options/.
We need to add the limit to each group, not an overall limit, so we can't add it through the options argument in pickerInput, have to do it in raw HTML or use some js code to inject like what I do.
Be sure your inputId="pick" matches the id in the script #pick. Rename pick to whatever you want.
ui <- fluidPage(
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")),
multiple = TRUE
),
tags$script(
'
$(function(){
$("#pick optgroup").attr("data-max-options", "1");
})
'
)
)
server <- function(input, output, session){}
shinyApp(ui, server)
updates:
If you need to update, we need to run the script again but from server. We can send js by using {shinyjs}. Imagine an observer triggers the update event.
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =NULL,
multiple = TRUE
)
)
server <- function(input, output, session){
observe({
shinyWidgets::updatePickerInput(session, "pick", choices = list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")))
observeEvent(once = TRUE, reactiveValuesToList(session$input), {
runjs('$("#pick optgroup").attr("data-max-options", "1");')
}, ignoreInit = TRUE)
})
}
shinyApp(ui, server)

Startup evaluation of server-side reactive

I need a reactive variable (declared server-side) available after start-up. Using what I learned here How to create a conditional renderUI in Shiny dashboard I tried wrapping in reactive() before defining the UI but no luck. Moving topValuesSelector to the UI inside a conditionalPanel would work except conditional panels apparently do not like the %in% operator (a separate issue that I also tried to resolve w/o success).
if (interactive()) {
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <-
dashboardPage(header = dashboardHeaderPlus(left_menu = tagList(
dropdownBlock(
id = "prefDropdown",
title = "Preferences",
icon = NULL,
badgeStatus = NULL,
checkboxGroupInput(
inputId = "prefDropdown",
label = NULL,
choices = c("Pareto",
"Legend on chart",
"Cases/1K uniques",
"Top 10 only"),
selected = c("Pareto", "Cases/1K uniques", "Top 10 only")
),
uiOutput("topValues")
)
)),
dashboardSidebar(),
dashboardBody(fluidRow(box(
title = "Top",
textOutput("topN")
))))
server <- function(input, output) {
topValuesSelector <- reactive({
if ("Top 10 only" %in% input$prefDropdown) {
numericInput(
inputId = "topValues",
label = NULL,
width = "25%",
value = 10,
min = 1,
max = 30,
step = 1
)
}
})
output$topValues <- renderUI({
topValuesSelector()
})
observe({
if ("Top 10 only" %in% input$prefDropdown) {
output$topN <- renderText(input$topValues)
} else{
output$topN <- renderText(100)
}
})
}
shinyApp(ui, server)
}
The intent is for the initial value of "topValues" to be 10 with this value immediately available. However, no value is available which causes an error. Using req() avoids the error by pausing execution but that is not a viable approach because "topValues" is needed for a plot. So no plot until selecting "prefDropdown".
It looks like the problem is that input$topValues does not exist until you click on the Preferences button. Since the UI element isn't needed it hasn't been created yet.
In order to work around that you can create a variable that detects whether or not the input is available and if not use a default value.
if (interactive()) {
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <-
dashboardPage(header = dashboardHeaderPlus(left_menu = tagList(
dropdownBlock(
id = "prefDropdown",
title = "Preferences",
icon = NULL,
badgeStatus = NULL,
checkboxGroupInput(
inputId = "prefDropdown",
label = NULL,
choices = c("Pareto",
"Legend on chart",
"Cases/1K uniques",
"Top 10 only"),
selected = c("Pareto", "Cases/1K uniques", "Top 10 only")
),
uiOutput("topValues")
)
)),
dashboardSidebar(),
dashboardBody(fluidRow(box(
title = "Top",
textOutput("topN")
))))
server <- function(input, output) {
## We want to use the same default value in two places so create a var
default_value <- 10
topValuesSelector <- reactive({
if ("Top 10 only" %in% input$prefDropdown) {
numericInput(
inputId = "topValues",
label = NULL,
width = "25%",
value = default_value, ## Change to use the default value
min = 1,
max = 30,
step = 1
)
}
})
output$topValues <- renderUI({
topValuesSelector()
})
## Create a variable that is the default value unless the input is available
myTopN <- reactive({
if(length(input$topValues)>0){
return(input$topValues)
}
return(default_value)
})
observe({
if ("Top 10 only" %in% input$prefDropdown) {
# output$topN <- renderText(input$topValues)
output$topN <- renderText(myTopN()) ## Use our new variable instead of the input directly
} else{
output$topN <- renderText(100)
}
})
}
shinyApp(ui, server)
}
There are a couple of other things going on with your code. Notice that "Top 10 only" %in% input$prefDropdown will not do what you think it is doing. You have to check to see if "Top 10 only" is TRUE... I'll leave you there to start another question if you get stuck again.

R Shiny Radio Buttons not Updating with updateRadioButtons

I'm working on a quiz type program in Shiny, which needs to have radio buttons that update with answers from a table. I have the code below, but the radio buttons don't update, and the answers remain 2, 3, 4, 5, and 6 despite changing questions. Any ideas on why this might be happening, and what would fix this?
library(shiny)
ui <- fluidPage(
selectInput("numberchoice",label = "Choose an image", choices = c(1:6), selected = 1)
,
imageOutput("image")
,
radioButtons("answerchoice", "Answers", choices = c(2:6))
)
server <- function(input,output,session) {
answers <- read.csv("~/Answers.csv")
questions <- read.csv("~/Answers.csv")
output$image <- renderImage(list(src = paste("~",".png", sep = "")
,contentType = "image/png", alt = "Face"),deleteFile = FALSE)
eventReactive(input$numberchoice,{updateRadioButtons(session,"answerchoice",choices = questions[input$numberchoice,2:6])})
}
shinyApp(ui = ui, server = server)
Try replacing eventReactive with observeEvent. The following code works for me.
library(shiny)
ui <- fluidPage(
selectInput("numberchoice", label = "Choose an image", choices = 1:6, selected = 1),
radioButtons("answerchoice", "Answers", choices = 1:6 )
)
server <- function(input, output, session) {
observeEvent(input$numberchoice,{
updateRadioButtons(session, "answerchoice",
choices = letters[1:input$numberchoice])})
}
shinyApp(ui = ui, server = server)
It seems like eventReactive didn't trigger so updateRadioButtons was not the problem.

Showing and hiding inputs based on checkboxGroupInput

My shiny app begins with a checkboxGroupInput which contains the names of three companies: A, B and C. It also has 3 hidden numeric inputs, each corresponding to a company. Potential investors may select the name of the company they wish to invest in and specifiy the amount they are willing to invest. When the name of a company is checked, the corresponding numeric input shows up. Also, when the company name is unchecked, the numeric input disappears.
The checkboxGroupInput is called company. The 3 numericInput fields are respectively called amountA, amountB and amountC and are all generated inside a uiOutput. They are hidden with the hidden function of shinyjs.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observeEvent(eventExpr = input$company, handlerExpr = {
if(length(input$company) == 0){
for(i in num_ids){
shinyjs::hide(id = i)
}
} else {
for(i in input$company){
shinyjs::toggle(id = paste0("amount", i), condition = input$company)
}
}
})
}
shinyApp(ui = ui, server = server)
The problem with my app is that the intended dynamics between the checkboxGroupInput and the numericInput fields are not working as intended. For instance, once a numericInput is shown, it cannot be hidden anymore by unchecking the boxes. How can I handle this?
The code pasted above is fully functional. Thank you very much.
I fixed your code by explicitly show/hide the numericInput when the corresponding check box is selected/unselected. Also I change the observeEvent with observe to make sure that the observer reacts when none of the check boxes are selected.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observe({
for(i in company_names){
if (i %in% input$company) {
shinyjs::show(id = paste0("amount", i))
} else {
shinyjs::hide(id = paste0("amount", i))
}
}
})
}
shinyApp(ui = ui, server = server)

Resources