Блог

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

Одновременно на другой вкладке я создаю тепловую карту всех этих снимков. Однако в моей тепловой карте (созданной в моем коде в output $ chart) Я хотел бы иметь два разных цвета на одной тепловой карте. Один цвет представляет удары, а другой — цель.

Спасибо за вашу помощь

 library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Hockey"),
  tags$img(height = 100, width = 100,
           src = "Logo.png"),
  sidebarPanel(
    textInput(inputId = "date",
              label = "Date", 
              value = "yyyy/mm/dd"),
    textInput(inputId = "team",
              label = "Team Name", 
              value = "Team Name"),
    selectInput("shot", "shot type:",
                list(`Shot Type` = list("wrist shot", "slap shot", "snap shot", "backhand", "tap in", "deflection", "one timer", "wrap around"))),
    actionButton("reset", "Clear")),
  mainPanel(tabsetPanel(
    tabPanel("Track", plotOutput(outputId = "hockeyplot", click = "plot_click", dblclick = "plot_dblclick")),
    tabPanel("Chart", plotOutput(outputId = "chart")),
   

server <- function(input, output){
  
  rv <- reactiveValues(
    df = data.frame(
      x = numeric(),
      y = numeric(),
      Date = as.Date(character()),
      Team = character(),
      ShotType = character(),
      Type = factor()
    )
  )
  
  output$hockeyplot = renderPlot({ 
    ggplot(rv$df,
           aes(x = x, y = y))   coord_flip()   lims(x = c(0, 100), y = c(42.5, -42.5))   geom_blank   geom_point( aes(colour = factor(Type)), size = 5 )   theme(legend.position = "none")})
  
  
   observeEvent(input$plot_click, {
    rv$df <- rbind(rv$df, data.frame(
      x = input$plot_click$y,
      y = input$plot_click$x,
      Date = input$date, 
      Team = input$team, 
      ShotType = input$shot, 
      Type = "Shot"))
  })
  
  observeEvent(input$plot_dblclick, {
    rv$df <- rbind(rv$df, data.frame(
      x = input$plot_dblclick$y,
      y = input$plot_dblclick$x,
      Date = input$date, 
      Team = input$team,  
      ShotType = input$shot, 
      Type = "Goal"))
  })
  
  observeEvent(input$reset,{
    rv$df <- rv$df[-nrow(rv$df),]
  })
  

  
  output$chart = renderPlot({
    ggplot(rv$df, aes(x = x, y = y))  
      coord_flip() 
      lims(x = c(0, 100), y = c(42.5, -42.5))  
      geom_blank 
      theme(legend.position = "none")  
      stat_density_2d(aes(fill = "shot"), geom = 'polygon', alpha = 0.4) 
  })

  

Вот рабочий пример.

Я создал вектор my_colors для присвоения цветов «Shot» и «Goal», чтобы они соответствовали цифрам и не менялись, если Type factor имеет разное количество уровней.

Я также включил factor при добавлении строк в ваш rv$df . Таким образом, у вас также не будет изменения цвета при изменении количества уровней Type . Когда я попытался запустить приложение изначально, цвета изменились бы после Type добавления секунды («Выстрел» или «Цель»).

В stat_2_density , вы можете изменить fill на Type . Опять же, вы можете указать scale_fill_manual , чтобы назначить те же цвета.

Пожалуйста, дайте мне знать, если это то, что вы имели в виду.

 library(shiny)
library(ggplot2)

my_colours = c("Shot" = "blue", "Goal" = "green")

ui <- fluidPage(
  titlePanel("Hockey"),
  tags$img(height = 100, width = 100, src = "Logo.png"),
  sidebarPanel(
    textInput(inputId = "date",
              label = "Date", 
              value = "yyyy/mm/dd"),
    textInput(inputId = "team",
              label = "Team Name", 
              value = "Team Name"),
    selectInput("shot", "shot type:",
                list(`Shot Type` = list("wrist shot", "slap shot", "snap shot", "backhand", "tap in", "deflection", "one timer", "wrap around"))),
    actionButton("reset", "Clear")),
  mainPanel(tabsetPanel(
    tabPanel("Track", plotOutput(outputId = "hockeyplot", click = "plot_click", dblclick = "plot_dblclick")),
    tabPanel("Chart", plotOutput(outputId = "chart"))
  ))
)
    
    
server <- function(input, output){
  
  rv <- reactiveValues(
    df = data.frame(
      x = numeric(),
      y = numeric(),
      Date = as.Date(character()),
      Team = character(),
      ShotType = character(),
      Type = factor(levels = c("Shot", "Goal"))
    )
  )
  
  output$hockeyplot = renderPlot({ 
    ggplot(rv$df, aes(x = x, y = y))   
      coord_flip()   
      lims(x = c(0, 100), y = c(42.5, -42.5))   
      geom_blank()   
      geom_point(aes(color = Type), size = 5 )   
      theme(legend.position = "none")  
      scale_color_manual(values = my_colours)
  })
  
  observeEvent(input$plot_click, {
    rv$df <- rbind(rv$df, data.frame(
      x = input$plot_click$y,
      y = input$plot_click$x,
      Date = input$date, 
      Team = input$team, 
      ShotType = input$shot, 
      Type = factor("Shot", levels = c("Shot", "Goal"))))
  })
  
  observeEvent(input$plot_dblclick, {
    rv$df <- rbind(rv$df, data.frame(
      x = input$plot_dblclick$y,
      y = input$plot_dblclick$x,
      Date = input$date, 
      Team = input$team,  
      ShotType = input$shot, 
      Type = factor("Goal", levels = c("Shot", "Goal"))))
  })
  
  observeEvent(input$reset,{
    rv$df <- rv$df[-nrow(rv$df),]
  })
  
  output$chart = renderPlot({
    ggplot(rv$df, aes(x = x, y = y))  
      coord_flip() 
      lims(x = c(0, 100), y = c(42.5, -42.5))  
      geom_blank() 
      theme(legend.position = "none")  
      stat_density_2d(aes(fill = Type), geom = 'polygon', alpha = .4)  
      scale_fill_manual(values = my_colours)
  })
  
}

shinyApp(ui, server)