Shiny, наблюдать за событием, updateSelectInput, сброс входов - PullRequest
Новая
       36

Shiny, наблюдать за событием, updateSelectInput, сброс входов

0 голосов
/ 08 февраля 2020

При выборе параметров ввода все возвращается правильно. Однако, если я изменил предыдущий фильтр после выбора всех фильтров, он сбрасывает следующий вход. Вот gif как пример

После того, как вы смотрите gif, последняя его часть I go возвращается к предыдущему вводу, чтобы изменить его, а следующий сбрасывается. Это то, чего я не хочу.

Вот пример базового c примера кода, который я использую, чтобы вы могли воспроизвести его: 

library(shinyWidgets)
library(shiny)
library(tidyverse)
teamname<-sample(c('Gig/Gog', 'Walsh/Sweat', 'Klineman/Ross', 'Lucena/Dalhausser', 'Bourne/Crabb', 'Gibb/Crabb', 'R/Python', 'Fendrick/Hughes', 'Tyler/Corley', 'David/Russ'), 50000, replace=T)
opponent<-sample(c('UKR', 'LAT', 'NOR', 'FIN', 'FRA', 'USA', 'CAN', 'RUS', 'SUI', 'GER', 'BRA', 'ARG', 'CHI', 'CHN', 'JPN', 'TAI', 'BEL'), 50000, replace = T)
name<-sample(c('CB', 'TW'), 50000, replace = T)
block<-sample(c('line', 'angle', 'peel'), 50000, replace = T)
np<-sample(c(1:5), 50000, replace = T)
fbso_rec_details<-sample(c('right', 'left', 'low', 'middle'), 50000, replace = T)
details <- sample(c('shot', 'hard', 'pokey'), 50000, replace = T)
tourn_info <- sample(c('HAG 4* Aye/Gauthier-Rat FRA vs A. Mirzaali/Raoufi R. IRI [2-0] Round 2Q',
                       'HAG 4* Bello/Bello, J. ENG vs A. Mirzaali/Raoufi R. IRI [0-2] Round 1Q',
                       'HAM WC A.Vakili/Salemi B. IRI vs Lupo/Nicolai ITA [1-2] Round of 32',
                       'HAM WC Bourne/Crabb Tr. USA vs A.Vakili/Salemi B. IRI [2-1] Pool L',
                       'HAM WC A.Vakili/Salemi B. IRI vs Kavalo/Ntagengwa RWA [2-0] Pool L',
                       'HAG 4* Juchnevic/Vasiljev LTU vs A.Vakili/Salemi B. IRI [2-0] Round 1Q',
                       'HAM WC Thole, J./Wickler GER vs A.Vakili/Salemi B. IRI [2-0] Pool L',
                       'HAG 4* Abbiati/Andreatta, T. ITA vs Sekerci/Urlu TUR [2-1] Round 2Q',
                       'JIN 4* Berntsen/Mol, H. NOR vs Abbiati/Andreatta, T. ITA [2-1] Pool D',
                       'ESP 4* Abbiati/Andreatta, T. ITA vs Durant/Schumann AUS [2-0] Pool F',
                       'VIE 5* Abbiati/Andreatta, T. ITA vs Erdmann/Winter GER [1-2] Round 1',
                       'ESP 4* Grimalt E./Grimalt M. CHI vs Abbiati/Andreatta, T. ITA [2-0] Round 1',
                       'CEV CEV Bryl/Fijalek POL vs Abbiati/Andreatta, T. ITA [2-1] Pool D',
                       'SYD 3* Doherty/Hyden USA vs Abbiati/Andreatta, T. ITA [2-1] Round 2',
                       'ROM WTF P. Gao/Y. Li CHN vs Abbiati/Andreatta, T. ITA [2-1] Round 1',
                       'CEV CEV Liamin/Myskiv RUS vs Abbiati/Andreatta, T. ITA [2-1] Pool D',
                       'SYD 3* Abbiati/Andreatta, T. ITA vs Basta/Kolaric SRB [2-0] Round 1',
                       'HAG 4* alvaro Filho/Ricardo BRA vs Abbiati/Andreatta, T. ITA [0-2] Pool F',
                       'CEV CEV Abbiati/Andreatta, T. ITA vs Giginoglu/Gogtepe V. TUR [1-2] Pool D',
                       'SYD 3* Kazdailis/Rumsevicius LTU vs Abbiati/Andreatta, T. ITA [2-1] Pool F',
                       'SYD 3* Abbiati/Andreatta, T. ITA vs J. Surin/P. Sedtawat THA [2-1] Pool F',
                       'HAG 4* Krasilnikov/Stoyanovskiy RUS vs Abbiati/Andreatta, T. ITA [2-0] Pool F',
                       'HAG 4* Abbiati/Andreatta, T. ITA vs Aye/Gauthier-Rat FRA [1-2] Round 1',
                       'JIN 4* Liamin/Myskiv RUS vs Abbiati/Andreatta, T. ITA [2-0] Pool D',
                       'GST 5* Abbiati/Andreatta, T. ITA vs Erdmann/Winter GER [0-2] Round 1',
                       'HAG 4* Abell/Thomsen DEN vs Barthelemy/Loiseau FRA [0-2] Round 1Q'), 50000, replace = T)
st <- data.frame(teamname, opponent, name, block, np, fbso_rec_details, details, tourn_info)
st$teamname <- as.character(st$teamname)
st$opponent <- as.character(st$opponent)
st$name <- as.character(st$name)
st$block <- as.character(st$block)
st$fbso_rec_details <- as.character(st$fbso_rec_details)
st$details <- as.character(st$details)
st$np <- as.integer(st$np)
st$tourn_info <- as.character(st$tourn_info)


ui <- fluidPage(
  titlePanel("Dashboard"),
  sidebarLayout(
    sidebarPanel(
      selectizeInput("Select1","Team",unique(st$teamname)),
      pickerInput("Select2","Opponent", choices=NULL, options = list('actions-box' = T, size = 12), multiple = T),
      selectizeInput("Select3","Player",choices = NULL),
      pickerInput("Select5","Block",choices=NULL, options = list('actions-box' = T, size = 12), multiple = T),
      pickerInput("Select6","NP",choices=NULL, options = list('actions-box' = T, size = 12), multiple = T),
      pickerInput("Select7","Reception type",choices=NULL, options = list('actions-box' = T, size = 12), multiple = T),
      pickerInput("Select8","Attack type",choices=NULL, options = list('actions-box' = T, size = 12), multiple = T)), mainPanel()))

server <- function(input, output, session) {

  observeEvent(input$Select1,{
    updatePickerInput(session,'Select2',choices=unique(sort(
      st$tourn_info[st$teamname==input$Select1])))}) 

  observeEvent(input$Select2,{
    updateSelectInput(session,'Select3',choices=unique(sort(
      st$name[st$teamname==input$Select1 & st$tourn_info %in% input$Select2])))}) 

  observeEvent(input$Select3,{
    updatePickerInput(session,'Select5',choices=unique(sort(
      st$block[st$teamname==input$Select1 & st$tourn_info %in% input$Select2 & st$name == input$Select3])))})

  observeEvent(input$Select5,{
    updatePickerInput(session,'Select6',choices=unique(sort(
      st$np[st$teamname==input$Select1 & st$tourn_info %in% input$Select2 & st$name == input$Select3  & st$block %in% input$Select5])))})

  observeEvent(input$Select6,{
    updatePickerInput(session,'Select7',choices=unique(sort(
      st$fbso_rec_details[st$teamname==input$Select1 & st$tourn_info %in% input$Select2 & st$name == input$Select3 & st$block %in% input$Select5 & st$np %in% input$Select6])))})

  observeEvent(input$Select7,{
    updatePickerInput(session,'Select8',choices=unique(sort(
      st$details[st$teamname==input$Select1 & st$tourn_info %in% input$Select2 & st$name == input$Select3  & st$block %in% input$Select5 & st$np %in% input$Select6 & st$fbso_rec_details %in% input$Select7])))})
}
  shinyApp(ui, server)

1 Ответ

1 голос
/ 08 февраля 2020

Во-первых, это упрощенный пример проблемы: 

library(shiny)

dd <- data.frame(in1=rep(LETTERS[1:3], 2), in2=letters[1:6])

ui <- basicPage(
    selectInput(
        inputId = "in1",
        label = "in1",
        choices = unique(dd$in1), 
        multiple = TRUE
    ),
    selectInput(
        inputId = "in2",
        label = "in2",
        choices = unique(dd$in2),
        multiple = TRUE
    )
)

server <- function(input, output, session) {

    observeEvent(input$in1, {
        updateSelectInput(
            session = session,
            inputId = "in2",
            label = "updated in2",
            choices = dd[dd$in1 %in% input$in1, "in2"]
        )
    }
    )
}

shinyApp(ui, server)

Мы можем получить значения без сброса с помощью reactiveVal, чтобы сохранить уже сделанные выборки и передать содержимое reactiveVal до selected аргумента update*input. Ниже приведено доказательство концепции в более простом случае с двумя входами: 

library(shiny)

dd <- data.frame("in1"=rep(LETTERS[1:3], 2), "in2"=letters[1:6], stringsAsFactors = FALSE)

ui <- basicPage(
    selectInput(
        inputId = "in1",
        label = "in1",
        choices = unique(dd$in1), 
        multiple = TRUE
    ),
    selectInput(
        inputId = "in2",
        label = "in2",
        choices = unique(dd$in2),
        multiple = TRUE
    )
)

server <- function(input, output, session) {

    current_in2 <- reactiveVal()

    observe({
        current_in2(input$in2)  
    })

    # as normal except notice that
    # `current_in2()` sets the pre-selected choices 
    observeEvent(eventExpr = input$in1,
                 handlerExpr = {
                     updateSelectInput(
                         session = session,
                         inputId = "in2",
                         label = "in2",
                         # keep what we had before
                         selected = current_in2(),
                         choices = dd[dd$in1 %in% input$in1, "in2"]
                     )
                 })
}

shinyApp(ui, server)

gif

...