Обновление checkboxGroupInput на основе выбора из предыдущего checkboxGroupInput - PullRequest
Новая
       34

Обновление checkboxGroupInput на основе выбора из предыдущего checkboxGroupInput

1 голос
/ 20 июня 2019

У меня есть несколько входов для функции ggplot, которая создает тепловую карту зоны удара.

Я пытаюсь сделать так, чтобы входы для флажков «HitType» и «PlayResult» появлялись, если в поле «PitchResult» установлен ТОЛЬКО флажок «В игре».

СВ моем текущем коде флажки «HitType» и «PlayResult» отменяют другие флажки, указанные выше, и влияют на данные ggplot, которые отображаются только как данные «в игре».

Я хочу иметь возможность выбрать все данные, независимо от того, находятся ли они в игре или нет («StrikeCalled», «BallCalled» и т. Д.).

У меня естьПрочтите о пакете блестящий, но я не уверен, что мне это нужно. 

data$Date <- as.Date(data$Date, "%m/%d/%Y")
PitchTypeList <- c("Fastball","Cutter","Sinker","Curveball","Slider","Changeup" = "ChangeUp","Splitter")
PitchResultList <- c("Hit By Pitch" = "HitByPitch","Ball Called" = "BallCalled","Strike Called" = "StrikeCalled",
                     "Strike Swinging" = "StrikeSwinging","Foul Ball" = "FoulBall","In Play" = "InPlay")
HitTypeList <- c("Bunt","Groundball" = "GroundBall","Line Drive" = "LineDrive","Fly Ball" = "FlyBall","Popup")
PlayResultList <- c("Out","Single","Double","Triple","Home Run" = "HomeRun")

ui = fluidPage(
  titlePanel("Heatmaps - 2019 Big Ten Conference Database"),

  sidebarLayout(
    sidebarPanel(
      selectInput(inputId="TeamInput", label="Select Team", choices = sort(unique(data$BatterTeam)), selected = "IOW_HAW"),
      selectInput(inputId="BatterInput", label="Select Player", choices = ""),
      dateRangeInput(input="DateRange", label="Select the date range", start=min(data$Date), end=max(data$Date)),
      checkboxGroupInput(inputId = "PitcherHandedness", label = "Pitcher Handedness", inline = TRUE,
                         choices = c("LHP"="Left","RHP"="Right"), selected = c("LHP"="Left","RHP"="Right")),
      fluidRow(  
      column(5, wellPanel(
       checkboxGroupInput(inputId = "PitchType", label= "Pitch Type", choices = PitchTypeList, selected = PitchTypeList) ) ),
      column(5, wellPanel(
       checkboxGroupInput(inputId = "PitchResult", label = "Pitch Result", choices = PitchResultList, selected = PitchResultList) ) )
               ),
      fluidRow(  
      column(5, wellPanel(
       checkboxGroupInput(inputId = "HitType", label= "Hit Type", choices = HitTypeList, selected = HitTypeList) ) ),
      column(5, wellPanel(
       checkboxGroupInput(inputId = "PlayResult", label = "Play Result", choices = PlayResultList, selected = PlayResultList) ) )
               )  
      ), #sidebarPanel closing

    mainPanel(
      plotOutput("myZone")
             )))

server = function(input, output, session) {

  observeEvent(
    input$TeamInput,
    updateSelectInput(session, "BatterInput", "Select Player",
                      choices = sort(unique(data$Batter[data$BatterTeam==input$TeamInput])))
  )

  output$myZone <- renderPlot({

    data$PlateLocSide <- (data$PlateLocSide * -1)

    dataFilter <- reactive({
      data %>% filter(
        between(Date, input$DateRange[1], input$DateRange[2]),
        BatterTeam %in% c(input$TeamInput),
        Batter %in% c(input$BatterInput),
        PitcherThrows %in% c(input$PitcherHandedness),
        TaggedPitchType %in% c(input$PitchType),
        PitchCall %in% c(input$PitchResult),
        HitType %in% c(input$HitType),
        PlayResult %in% c(input$PlayResult))
    })

    ggplot(data = dataFilter(), aes(x = PlateLocSide, y = PlateLocHeight)) + 
      stat_density_2d(geom = "tile", aes(fill = ..density..), contour = FALSE, na.rm = TRUE) +
      xlim(-2.5,2.5) + ylim(0,5) + geom_point(na.rm = TRUE) +
      labs(x = "", y = "") + facet_wrap(~ Batter, ncol = 2) +
      theme(strip.text = element_text(size=20, face="bold")) +
      scale_fill_gradientn(colors = c("white", "blue", "yellow", "red"), 
      values = scales::rescale(c(0, .05, 0.10, 0.15, .20))) + theme(legend.position="none")
  },
  width=425, height=500)


}

shinyApp(ui, server)
...