问题
New code example below where I'm trying to link selectInput in all three tabs. In the example below, the first two tabs selectInputs are linked but I'm trying to get all three linked. Is there any way to have all three linked?
#``````````````````````````````````````
a <- list("2016", "MALE", "25", "50")
b <- list("2017", "FEMALE", "5", "100")
c <- list("2017", "MALE", "15", "75")
d <- list("2016", "MALE", "10", "35")
e <- list("2017", "FEMALE","55", "20")
data <- rbind(a,b,c,d,e)
#``````````````````````````````````````
## UI
library(shiny)
if(interactive()){
ui = fluidPage(
navbarPage("",
#``````````````````````````````````````
## SHOES TAB
tabPanel("SHOES",
fluidRow(
column(2, "",
selectInput("shoes_year", "YEAR", choices = c("2017", "2016", "2015", "2014"))),
column(9, "SHOES"))),
#``````````````````````````````````````
## HATS
tabPanel("HATS",
fluidRow(
column(2, "",
selectInput("hats_year", "YEAR", choices = c("2017", "2016", "2015", "2014"))),
column(9, "HATS"))),
#``````````````````````````````````````
## COATS
tabPanel("COATS",
fluidRow(
column(2, "",
selectInput("coats_year", "YEAR", choices = c("2017", "2016", "2015", "2014"))),
column(9, "COATS")))
))
#``````````````````````````````````````
server = function(input, output, session) {
observeEvent(input[["shoes_year"]],
{
updateSelectInput(session = session,
inputId = "hats_year",
selected = input[["shoes_year"]])
})
observeEvent(input[["hats_year"]],
{
updateSelectInput(session = session,
inputId = "shoes_year",
selected = input[["hats_year"]])
})
}
#``````````````````````````````````````
shinyApp(ui, server)
}
#``````````````````````````````````````
回答1:
Some things to take note of:
- Your
inputId
s must be unique. You can't have twoselectInput
calls with the sameinputId
on two different tabs. It won't cast an error, but your app won't work the way you want. - You will need to include the
session
argument in your server function. - Having controls that perform the same task on two different tabs is somewhat redundant. You may want to consider if having a sidebar (
sidebarLayout
) would work to your advantage.
In any case, the code below works for updating the year selections.
a <- list("2016", "MALE", "25", "50")
b <- list("2017", "FEMALE", "5", "100")
c <- list("2017", "MALE", "15", "75")
d <- list("2016", "MALE", "10", "35")
e <- list("2017", "FEMALE","55", "20")
data <- rbind(a,b,c,d,e)
#``````````````````````````````````````
## UI
library(shiny)
if(interactive()){
ui = fluidPage(
navbarPage("",
#``````````````````````````````````````
## SHOES TAB
tabPanel("SHOES",
fluidRow(
column(2, "",
selectInput("shoes_year", "YEAR", choices = c("2017", "2016")),
selectInput("dataset", "CHOOSE POPULATION", choices = c("MALE", "FEMALE"))),
column(9, "SHOES"))),
#``````````````````````````````````````
## HATS
tabPanel("HATS",
fluidRow(
column(2, "",
selectInput("hats_year", "YEAR", choices = c("2017", "2016")),
selectInput("dataset", "CHOOSE POPULATION", choices =c("MALE","FEMALE"))),
column(9, "HATS"))
)))
#``````````````````````````````````````
server = function(input, output, session) {
observeEvent(input[["shoes_year"]],
{
updateSelectInput(session = session,
inputId = "hats_year",
selected = input[["shoes_year"]])
})
observeEvent(input[["hats_year"]],
{
updateSelectInput(session = session,
inputId = "shoes_year",
selected = input[["hats_year"]])
})
}
#``````````````````````````````````````
shinyApp(ui, server)
}
#``````````````````````````````````````
ADDITIONAL STUFF (technical term)
Based on your comment of doing this on three or more tabs, I'm going to strongly recommend you stop what you're doing. It's possible to do this through some clever lapply
ing, such as
observeEvent(input$coat_year,
{
lapply(c("shoes_year", "hats_year"),
function(x) updateSelectInput(session = session,
inputId = x,
selected = input$coat_year))
}
)
Which will minimize the amount of code you have to write, but you still need one of those blocks for each tab, and you will have to manually maintain the vector going into lapply
to make sure it consists of all of appropriate controls. Then you need to do it again for the data set. There are other options, but I'm not sure they are any less work.
You're reaching a phase where your application is of sufficient complexity that you really ought to find ways to minimize the code work to make it easier to maintain. I present two options below which use only the tools made available in shiny
. The first uses tabsetPanel
s instead of the navbarPage
. The second uses the navbarPage
but embeds it in a sidebarLayout
. There are many other solutions you could use if you explore the shinyjs
, shinydashboard
, and shinyBS
packages, just to name a few.
tabsetPanel
library(shiny)
shinyApp(
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("year", "YEAR", choices = c("2017", "2016")),
selectInput("dataset", "CHOOSE POPULATION", choices = c("MALE", "FEMALE"))
),
mainPanel(
tabsetPanel(
tabPanel(title = "Shoes",
uiOutput("shoe_input")),
tabPanel(title = "Hats",
uiOutput("hat_input"))
)
)
)
)
),
server = shinyServer(function(input, output, session){
selected_input <-
reactive({
tagList(
h3(input$year),
h3(input$dataset)
)
})
output$shoe_input <-
renderUI({
selected_input()
})
output$hat_input <-
renderUI({
selected_input()
})
})
)
navbarPage
library(shiny)
shinyApp(
ui = shinyUI(
sidebarLayout(
sidebarPanel(
selectInput("year", "YEAR", choices = c("2017", "2016")),
selectInput("dataset", "CHOOSE POPULATION", choices = c("MALE", "FEMALE"))
),
mainPanel(
navbarPage(
title = "",
tabPanel(title = "Shoes",
uiOutput("shoe_input")),
tabPanel(title = "Hats",
uiOutput("hat_input"))
)
)
)
),
server = shinyServer(function(input, output, session){
selected_input <-
reactive({
tagList(
h3(input$year),
h3(input$dataset)
)
})
output$shoe_input <-
renderUI({
selected_input()
})
output$hat_input <-
renderUI({
selected_input()
})
})
)
来源:https://stackoverflow.com/questions/43075333/selectinputupdate-in-r-selectinput-in-two-tabs-that-are-related