R блестящий, множественный selectInput и вычисления обновляются по мере выбора новых входов - PullRequest
0 голосов
/ 01 февраля 2020

Моя блестящая приборная панель selectInputs работает, как я хочу. Однако, когда дело доходит до обновления (или суммирования) общего значения geom_text при фильтрации более одного из входов True Multiple select на панели инструментов.

selectInput("Select2","Star",choices=NULL,multiple = T)

Текст перекрывается с более чем один selectInput используется. Я хочу «суммировать» общую стоимость, когда вводятся новые данные.

Вот мой код, который я использую с воспроизводимым примером.

library(shiny)
library(datavolley)
library(tidyverse)



ezt<-sample(1:9, 50000, replace = T)
est<-sample(c("A", "B", "C", "D"), 50000, replace = T)
np<-sample(c(1:5), 50000, replace = T)
grade<-sample(c('#', '=', '/', '-', '+'), 50000, replace=T)
block<-sample(c('line', 'angle', 'peel'), 50000, replace = T)
name<-sample(c('CB', 'TW'), 50000, replace = T)
teamname<-sample(c('Gig/Gog'), 50000, replace=T)
opponent<-sample(c('UKR', 'LAT', 'NOR', 'FIN', 'FRA'), 50000, replace = T)
star<-sample(c('4*', '3*', '2*', '1*', '5*'), 50000, replace = T)
sst <- data.frame(ezt, est, np, grade, block, name, teamname, opponent, star)
sst$est <- as.character(sst$est)
sst$teamname <- as.character(sst$teamname)
sst$name <- as.character(sst$name)
sst$opponent <- as.character(sst$opponent)
sst$star <- as.character(sst$star)
sst$np <- as.integer(sst$np)
sst$grade <- as.character(sst$grade)
sst$block <- as.character(sst$block)


sst <- sst %>% 
  dplyr::group_by(teamname, name, ezt, est, np, block, opponent, star) %>%
  dplyr::summarise(att = n(),
                   kill = sum(grade == '#'))

filteredxy <- datavolley::dv_xy(sst$ezt, end = 'lower', subzone = sst$est)
sst<-cbind.data.frame(sst, filteredxy)


ui <- fluidPage(
  titlePanel("Dashboard"),
  sidebarLayout(
    sidebarPanel(
      selectInput("Select1","Team",unique(sst$teamname)),
      selectInput("Select2","Star",choices=NULL,multiple = T),
      selectInput("Select3","Player",choices = NULL),
      selectInput("Select4","Opponent",choices=NULL,multiple = T),
      selectInput("Select5","Block",choices=NULL),
      selectInput("Select6","NP",choices=NULL)),
    mainPanel(plotOutput("coolplot"))))



server <- function(input, output, session) {
  observeEvent(input$Select1,{
    updateSelectInput(session,'Select2',
                      choices=unique(sst$star[sst$teamname==input$Select1]))
  }) 
  observeEvent(input$Select2,{
    updateSelectInput(session,'Select3',
                      choices=unique(sst$name[sst$teamname==input$Select1 & sst$star %in% input$Select2]))
  }) 
  observeEvent(input$Select3,{
    updateSelectInput(session,'Select4',
                      choices=unique(sst$opponent[sst$teamname==input$Select1 & sst$star %in% input$Select2 & 
                                                   sst$name == input$Select3]))
  })
  observeEvent(input$Select4,{
    updateSelectInput(session,'Select5',
                      choices=unique(sst$block[sst$teamname==input$Select1 & sst$star %in% input$Select2 & 
                                                sst$name == input$Select3 & sst$opponent %in% input$Select4]))
  })
  observeEvent(input$Select5,{
    updateSelectInput(session,'Select6',
                      choices=unique(sst$np[sst$teamname==input$Select1 & sst$star %in% input$Select2 & 
                                                 sst$name == input$Select3 & sst$opponent %in% input$Select4 & sst$block == input$Select5]))
  })
  output$coolplot <- renderPlot({
    filtered <-
      sst %>%
      filter(opponent %in% input$Select4, star %in% input$Select2) %>%
      filter(block == input$Select5, teamname == input$Select1, name == input$Select3, np == input$Select6) %>%
      group_by(name, teamname, np, block, x, y, opponent, star) %>%
      dplyr::summarise(att = sum(att),
                       kill = sum(kill))

    ggplot(filtered, aes(x, y, fill = (kill/att))) + 
      geom_tile() + 
      ggcourt("lower", labels = NULL, show_minor_zones = T) +
      geom_text(aes(label = att), position = position_dodge(0),vjust = -1) 
  })}

shinyApp(ui = ui, server = server)

Мое первое предположение - мой код в части графика рендеринга. Но потратив много времени на исследования, я решил, что пришло время написать об этом сообщение ... Это мой первый раз используя блестящий.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...