Как покрасить полосу, на которую щелкнули, из диаграммы, с помощью r, plolty, блестящий, если уже есть event_data ("plotly_click")

Question

Я пытаюсь понять, как event_data() работает, воссоздавая пример из Интерактивная веб-визуализация данных с рельефным и блестящим r , глава Связывание видов с блестящими : https://plotly-r.com/linking-views-with-shiny.html#fig: plotlyEvents , чтобы я мог окрасить выбранную полосу. Сначала, когда я запускаю код, я получаю:

"Предупреждение: событие 'plotly_click' связало идентификатор источника 'sub_category' не зарегистрировано. Чтобы получить данные этого события, добавьте event_register(p, 'plotly_click') к графику (p), из которого вы получите sh для получения данных о событии. Предупреждение: Событие 'plotly_click' связало идентификатор источника 'order_date' не зарегистрировано. Чтобы получить данные этого события, добавьте event_register(p, 'plotly_click') к графику (p), из которого вы получите sh для получения данных о событии. Предупреждение: Событие 'plotly_click', связавшее идентификатор источника 'sub_category', не зарегистрировано. Чтобы получить данные этого события, пожалуйста, добавьте event_register(p, 'plotly_click') к графику (p), из которого вы получите sh для получения данных о событии. Предупреждение: Событие 'plotly_click', связанное с идентификатором источника 'order_date', не зарегистрировано. Чтобы получить это событие данные, пожалуйста, добавьте event_register(p, 'plotly_click') к графику (p), с которым вы будете sh получать данные о событии. "

затем я прочитал о event_register() Я пытаюсь изменить код, но кроме взлома, я не достигаю много. Я также экспериментирую с highlight(), чтобы раскрасить панель, на которую нажали, но я полагаю, что я не правильно использую ее в этом примере, потому что снова код ломается. Не могли бы вы дать мне некоторое представление о том, как раскрасить столбцы, которые были выбраны, и подкатегории, чтобы они имели одинаковый цвет. Большое спасибо за ваше время!

  library(shiny)
  library(plotly)
  library(dplyr)


  sales <- diamonds
  sales$category = sales$cut
  sales$sub_category = sales$color
  sales$sales = sales$price
  sales$order_date = sample(seq(as.Date('2020-01-01'), as.Date('2020-02-01'), by="day"),nrow(sales), replace = T)



  ui <- fluidPage(
    plotlyOutput("category", height = 200),
    plotlyOutput("sub_category", height = 200),
    plotlyOutput("sales", height = 300),
    DT::dataTableOutput("datatable")
  )

  # avoid repeating this code
  axis_titles <- . %>%
    layout(
      xaxis = list(title = ""),
      yaxis = list(title = "Sales")
    )

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

    # for maintaining the state of drill-down variables
    category <- reactiveVal()
    sub_category <- reactiveVal()
    order_date <- reactiveVal()

    # when clicking on a category, 
    observeEvent(event_data("plotly_click", source = "category"), {
      category(event_data("plotly_click", source = "category")$x)
      sub_category(NULL)
      order_date(NULL)
    })

    observeEvent(event_data("plotly_click", source = "sub_category"), {
      sub_category(
        event_data("plotly_click", source = "sub_category")$x
      )
      order_date(NULL)
    })

    observeEvent(event_data("plotly_click", source = "order_date"), {
      order_date(event_data("plotly_click", source = "order_date")$x)
    })

    output$category <- renderPlotly({
      sales %>%
        count(category, wt = sales) %>%
        plot_ly(x = ~category, y = ~n, source = "category") %>%
        axis_titles() %>% 
        layout(title = "Sales by category")
    })

    output$sub_category <- renderPlotly({
      if (is.null(category())) return(NULL)

      sales %>%
        filter(category %in% category()) %>%
        count(sub_category, wt = sales) %>%
        plot_ly(x = ~sub_category, y = ~n, source = "sub_category") %>%
        axis_titles() %>%
        layout(title = category())
    })

    output$sales <- renderPlotly({
      if (is.null(sub_category())) return(NULL)

      sales %>%
        filter(sub_category %in% sub_category()) %>%
        count(order_date, wt = sales) %>%
        plot_ly(x = ~order_date, y = ~n, source = "order_date") %>%
        add_lines() %>%
        axis_titles() %>%
        layout(title = paste(sub_category(), "sales over time"))
    })

    output$datatable <-  DT::renderDataTable({
      if (is.null(order_date())) return(NULL)

      sales %>%
        filter(
          sub_category %in% sub_category(),
          as.Date(order_date) %in% as.Date(order_date())
        )
    })

  }

  shinyApp(ui, server)

Answer 1

Здесь вы go приятель, я только что добавил цвета, основанные на том, что вы нажали.

Линейный график по умолчанию был зеленым, поэтому нам не нужно об этом беспокоиться.
Для первого сюжета я изменю красный цвет, если щелкнуть категорию (). По какой-то причине я не смог изменить его напрямую, поэтому я создал plot_data перед графиком и сделал для этого операторы if else (вложенный if_else не работал)
Для второго графика я изменю зеленый цвет, если sub_category ()

Надеюсь, это то, что вы ищете!

library(shiny)
library(plotly)
library(dplyr)


sales <- diamonds
sales$category = sales$cut
sales$sub_category = sales$color
sales$sales = sales$price
sales$order_date = sample(seq(as.Date('2020-01-01'), as.Date('2020-02-01'), by="day"),nrow(sales), replace = T)



ui <- fluidPage(
  plotlyOutput("category", height = 200),
  plotlyOutput("sub_category", height = 200),
  plotlyOutput("sales", height = 300),
  DT::dataTableOutput("datatable")
)

# avoid repeating this code
axis_titles <- . %>%
  layout(
    xaxis = list(title = ""),
    yaxis = list(title = "Sales")
  )

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

  # for maintaining the state of drill-down variables
  category <- reactiveVal()
  sub_category <- reactiveVal()
  order_date <- reactiveVal()

  # when clicking on a category, 
  observeEvent(event_data("plotly_click", source = "category"), {
    category(event_data("plotly_click", source = "category")$x)
    sub_category(NULL)
    order_date(NULL)
  })

  observeEvent(event_data("plotly_click", source = "sub_category"), {
    sub_category(
      event_data("plotly_click", source = "sub_category")$x
    )
    order_date(NULL)
  })

  observeEvent(event_data("plotly_click", source = "order_date"), {
    order_date(event_data("plotly_click", source = "order_date")$x)
  })

  output$category <- renderPlotly({
    print(category())
    if (is.null(category())) {
      plot_data <- sales %>%
        count(category, wt = sales) %>%
        mutate(current_color = "blue")
    } else {
      plot_data <- sales %>%
        count(category, wt = sales) %>%
        mutate(current_color = if_else(category %in% category(), "red", "blue"))
    }
      plot_ly(
        plot_data, x = ~category, y = ~n, source = "category", type = "bar",
              marker = list(color = ~current_color)
      ) %>%
      axis_titles() %>% 
      layout(title = "Sales by category")
  })

  output$sub_category <- renderPlotly({
    if (is.null(category())) return(NULL)
    sales %>%
      filter(category %in% category()) %>%
      count(sub_category, wt = sales) %>%
      mutate(current_color = if_else(sub_category %in% sub_category(), "green", "red")) %>%
      plot_ly(
        x = ~sub_category, y = ~n, source = "sub_category", type = "bar",
        marker = list(color = ~current_color)
      ) %>%
      axis_titles() %>%
      layout(title = category())
  })

  output$sales <- renderPlotly({
    if (is.null(sub_category())) return(NULL)
    sales %>%
      filter(sub_category %in% sub_category()) %>%
      count(order_date, wt = sales) %>%
      plot_ly(x = ~order_date, y = ~n, source = "order_date", line = list(color = "green")) %>%
      add_lines() %>%
      axis_titles() %>%
      layout(title = paste(sub_category(), "sales over time"))
  })

  output$datatable <-  DT::renderDataTable({
    if (is.null(order_date())) return(NULL)

    sales %>%
      filter(
        sub_category %in% sub_category(),
        as.Date(order_date) %in% as.Date(order_date())
      )
  })

}

shinyApp(ui, server)