My shiny app has multiple tabPanels and I want to have a selectizeInput on each of these. However, the input only appears to update on the first panel - ie selectizeInput appears to work only on the first tab. The code below has two identical selectizeInputs which are the updated. Apologies if this is not reproducible elsewhere as it does seem to be odd behavior.
d <- c('t','u','o')
library(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel('a',uiOutput('a')),
tabPanel('b',uiOutput('b'))
))
server <- function(input, output, session){
output$a <- renderUI({
req(d)
selectizeInput(
'a','test1',choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
updateSelectizeInput(session,
'a',choices = d,
selected = NULL, server = TRUE)
})
output$b <- renderUI({
req(d)
selectizeInput(
'b','test2', choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
updateSelectizeInput(session,
'b',choices = d,selected = NULL,
server = TRUE)
})
}
shinyApp(ui, server)
It is reproducible (thanks!) and the answer is quite simple.
The problem lies in the order your elements are rendered.
(Description might be messy, because you named your elements ambiguously.)
Explanation: Your selected tabPanel is a since it's the first tab available. Your selectizeInput a is therefore rendered. It gets rendered as you specified, with choices = NULL.
Then both observers fire (not because they observe something, but because the server runs through all commands from top to bottom including all observers.)
This leads to selectizeInput a being updated to your choices in d and selectizeInput b is also being updated. Note, that at this point, selectizeInput b wasn't even rendered yet!
So, as you click on tabPanel b, selectizeInput b is rendered for the first time, and as you specified, it is rendered with choices = NULL. VoilĂ , no choices available.
Solution: You want your observers to observe, so to be run anytime something happens that is important to the observers content. In this case, that is a tabPanel change. In the code below, I added an id to your tabsetPanel and let the observers hear anything that happens with it.
d <- c('t','u','o')
library(shiny)
ui <- fluidPage(
tabsetPanel(id = "x",
tabPanel('a',uiOutput('a')),
tabPanel('b',uiOutput('b'))
))
server <- function(input, output, session){
output$a <- renderUI({
req(d)
selectizeInput(
'a','test1',choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
trigger <- input$x
updateSelectizeInput(session,
'a',choices = d,
selected = NULL, server = TRUE)
})
output$b <- renderUI({
req(d)
selectizeInput(
'b','test2', choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
trigger <- input$x
updateSelectizeInput(session,
'b',choices = d,selected = NULL,
server = TRUE)
})
}
shinyApp(ui, server)
Note: One might even cut one of the observers, and have the remaining one react to the value of input$x.
Related
I want to hide a selectInput so it doesnt let people try and use it before the data has loaded.
Snippet of UI code.
ui <- dashboardPage(
dashboardHeader(title = "TCS Adverse Event Search Tool"),
dashboardSidebar(
sidebarMenu(
shinycssloaders::withSpinner(
selectInput("ingredients",
label = "Select one or more Active Ingredients:",
choices = NULL,
multi=TRUE)
),
In my server function I have this:
server <- function(input, output, session) {
# get main data frame
ingredients_df <- reactive({
ingredients_df <- read.csv(file="/projects/other/pv_compliance/active_ingredients.csv")
print(paste(nrow(ingredients_df)," active ingredient rows returned"))
return(ingredients_df)
})
cases_df <- reactive({
cases_df <- read.csv(file="/projects/other/pv_compliance/adverse_events.csv")
print(paste(nrow(cases_df)," case rows returned"))
return(cases_df)
})
observeEvent(ingredients_df(), {
updateSelectInput(session,
"ingredients",
choices = ingredients_df()$PRIMARY_SUSPECT_KEY_INGREDIENT,
selected = NULL
)
})
Two things are happening...
the set of widgets now appear about halfway down the sidebar and not the top
the css loader does not display when the updateSelectInput is getting the data
I have an RShiny app using a navBarPage, something like:
default_run_date = Sys.Date()
ui <- navbarPage(
"MyTitle",
id="mainNavbarPage"
),
tabPanel(
"Panel1",
fluidPage(
dateInput("datePicker1",
"Run date:",
value = default_run_date,max = Sys.Date())
),
tabPanel(
"Panel2",
fluidPage(
dateInput("datePicker2",
"Run date:",
value = default_run_date,max = Sys.Date())
)
)
I actually have 5-6 different tabs and I want the user to be able to change a date that applies a setting across all of these tabs. For convenience I want users to have this control when accessing either of two different tabs.
I tried setting up a pair of observers:
observeEvent(input$datePicker1,{updateDateInput(session,inputId ="datePicker2",value=input$datePicker1)})
observeEvent(input$datePicker2,{updateDateInput(session,inputId ="datePicker1",value=input$datePicker2)})
However each of these events actually triggers the other, resulting in an infinite loop.
Can anyone tell me a better way to handle this?
In this case, I would not use renderUI as the complete dateInput has to be rendered on the server side. This causes delays in updating the value, already visible in this toy example. This blog post describes why using updateInput and doing the change on the client side is faster. You can apply this approach here as following:
library(shiny)
ui <- navbarPage("MyTitle", id="mainNavbarPage",
tabPanel("Panel1", dateInput("datePicker1",
"Run date:",
value = Sys.Date(),
max = Sys.Date())),
tabPanel("Panel2", dateInput("datePicker2",
"Run date:",
value = Sys.Date(),
max = Sys.Date())))
server <- function(input, output, session){
# Default starting value for date pickers
date_chosen <- reactiveVal(Sys.Date())
observeEvent(input$datePicker1, {
date_chosen(input$datePicker1)
})
observeEvent(input$datePicker2, {
date_chosen(input$datePicker2)
})
observeEvent(date_chosen(), {
updateDateInput(session,
"datePicker1",
value = date_chosen())
updateDateInput(session,
"datePicker2",
value = date_chosen())
})
}
shinyApp(ui = ui, server = server)
Store the chosen date in a reactiveVal. Then use renderUI to recreate the date pickers whenever the reactiveVal changes.
library(shiny)
ui <- navbarPage("MyTitle", id="mainNavbarPage",
tabPanel("Panel1", uiOutput("date_ui_1")),
tabPanel("Panel2", uiOutput("date_ui_2")))
server <- function(input, output, session){
# Default starting value for date pickers
date_chosen <- reactiveVal(Sys.Date())
output$date_ui_1 <- renderUI({
dateInput("datePicker1",
"Run date:",
value = date_chosen(),
max = Sys.Date())
})
output$date_ui_2 <- renderUI({
dateInput("datePicker2",
"Run date:",
value = date_chosen(),
max = Sys.Date())
})
observeEvent(input$datePicker1, {
date_chosen(input$datePicker1)
})
observeEvent(input$datePicker2, {
date_chosen(input$datePicker2)
})
}
shinyApp(ui = ui, server = server)
I saw some previous questions that may circle around this issue, but I couldn't find a clear answer to that.
My problem is that an ui element added using insertUI that depends on a reactive value does not update.
In the example I gave below, if one adds the new selectInput using the button and then changes the gender selection, the choices are updated only in the first selectInput.
The question is: is there an "official" way to make this selectInput reactive? I can imagine some workarounds, but they are not ideal.
server.R
library(shiny)
library(tidyverse)
server <- function(input, output, session) {
data <- reactive({
req(input$genderSelection)
starwars %>%
filter(gender == input$genderSelection)
})
output$characterSelection1 <- renderUI({
selectInput(
"char1",
"Character 1",
choices = data() %>%
.$name
)
})
observeEvent(
input$btn,
{
insertUI(
selector = "#selection2",
where = "beforeEnd",
ui = selectInput(
"char2",
"Character 2",
choices = data() %>%
.$name
)
)
}
)
}
ui.R
ui <- fluidPage(
radioButtons(
"genderSelection",
"Gender",
choices = c("male", "female")
),
uiOutput("characterSelection1"),
tags$div(
id = "selection2",
actionButton("btn", "Add selection")
)
)
Here is an existing example
library(shiny)
runExample("06_tabsets")
And you will see you can choose distribution type in radiobutton and there are three tabs "Plot", "Summary", and "Table".
My question is how can I add a selectInput under the sliderInput(number of observations) with two values. The default one is "NULL", the second one is "1". Once users select "1", the previous three tabs would disappear. Instead, a new tab would show whatever it content is.
This is the modified "06_tabsets". A select input is added and the UI is generated depending of the selection. The only difference is that is not using NULL, but two options. I could make it run with NULL. Let me know if this helps.
ui.R
library(shiny)
# Define UI for random distribution application
shinyUI(fluidPage(
# Application title
titlePanel("Tabsets"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")),
br(),
sliderInput("n",
"Number of observations:",
value = 500,
min = 1,
max = 1000),
selectInput("contentSelect", "Select content to dislay:", choices = c("1", "2"), selected = 1)
),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(
uiOutput("content")
)
)
))
server.R
library(shiny)
# Define server logic for random distribution application
shinyServer(function(input, output) {
# Reactive expression to generate the requested distribution.
# This is called whenever the inputs change. The output
# functions defined below then all use the value computed from
# this expression
data <- reactive({
dist <- switch(input$dist,
norm = rnorm,
unif = runif,
lnorm = rlnorm,
exp = rexp,
rnorm)
dist(input$n)
})
# Generate a plot of the data. Also uses the inputs to build
# the plot label. Note that the dependencies on both the inputs
# and the data reactive expression are both tracked, and
# all expressions are called in the sequence implied by the
# dependency graph
output$plot <- renderPlot({
dist <- input$dist
n <- input$n
hist(data(),
main=paste('r', dist, '(', n, ')', sep=''))
})
# Generate a summary of the data
output$summary <- renderPrint({
summary(data())
})
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
output$textA <- renderText({
paste(input$contentSelect, " A")
})
observeEvent(input$contentSelect, {
if (input$contentSelect == "1") {
output$content <- renderUI({
tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Summary", verbatimTextOutput("summary")),
tabPanel("Table", tableOutput("table"))
)
})
} else {
output$content <- renderUI({
tabsetPanel(type = "tabs",
tabPanel("A", textOutput("textA"))
)
})
}
})
})
How can I get the list of choices in a SelectInpute?
ui.R
selectInput(inputId = "select_gender",
label = "Gender",
choices = c("Male","Female"),
width = 150
)
server.R
# Something like...
genders <- input$select_gender["choices"]
# So that the gender would be:
> genders
[1] Male Female
From the scoping rules of Shiny:
Objects defined in global.R are similar to those defined in app.R outside of the server function definition, with one important difference: they are also visible to the code in the ui object. This is because they are loaded into the global environment of the R session; all R code in a Shiny app is run in the global environment or a child of it.
However, this doesn't mean that objects defined in the app.R can't be used on both the UI and Server side, they just belong to a different environment.
For example:
library("shiny")
library("pryr")
# or in global.R
genders <- c("Male", "Female")
gen_env <- where("genders")
par_env <- parent.env(gen_env)
ui <- fluidPage(
selectInput("shiny_gender", "Select Gender", choices = genders),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print")
)
server <- function(input, output) {
output$selected_gender_index <- renderPrint({
# use the 'genders' vector on the server side as well
which(genders %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(gen_env)
output$par_env_print <- renderPrint(par_env)
}
shinyApp(ui = ui, server = server)
I've looked for get choices of selectinput but without recompute the choices. For example if the datas come from database, or file or other source.
And I didn't get answer. (I get this question but not the solution for me).
Here is ma solution which also could set the selectinput from the server:
set the choices list in a reactive function
build the selectinput in the server side (with the choices list reactive function)
set and get the selectinput in the server side
Here is the code
options(encoding = "UTF-8")
library("shiny")
library("pryr")
ui <- fluidPage(
uiOutput("shiny_gender.UI"),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print"),
p(""),
textInput("set_input_txt","Set the car in letter (for example `Datsun 710`)",
#" Set the Select Input Male / Female ",
""),
actionButton("submit","submit")
)
server <- function(input, output, session) {
observeEvent(
c(input$submit),
{
if (input$submit>0) {
updateSelectInput(session, "shiny_gender",
# server = TRUE, if updateSelectizeInput
choices =shiny_gender.list(),
selected = input$set_input_txt
)
}
}
)
shiny_gender.list <- reactive ({
#c("Male", "Female")
rownames(mtcars)
})
output$shiny_gender.UI <- renderUI({
selectInput( "shiny_gender",
label="Select car",#"Select Gender",
choices =shiny_gender.list()
)
})
output$selected_gender_index <- renderPrint({
which(shiny_gender.list() %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(where("shiny_gender.list"))
output$par_env_print <- renderPrint(parent.env( where("shiny_gender.list")))
}
shinyApp(ui = ui, server = server)