如何在已有事件数据（“plotly”u click）的情况下，使用r、plolty、shiny为条形图中单击的条形图上色

我试图通过重新创建一个示例来了解

event_data（）

是如何工作的，该示例来自交互式基于web的数据可视化，带有r plotly和shinny，章节链接视图和shinny： 这样我就可以给选中的条上色了。 首先，当我运行代码时，我得到：

警告：未注册源ID为“子类别”的“plotly\u click”事件。为了获取此事件数据，请将

事件注册表（p，“plotly\u click”）

添加到您希望从中获取事件数据的绘图（

p

）中。 警告：源ID为“order\u date”的“plotly\u click”事件未注册。若要获取此事件数据，请将

事件注册表（p，“plotly\u click”）

添加到要从中获取事件数据的绘图（

p

）。 警告：未注册源ID为“子类别”的“plotly\u click”事件。若要获取此事件数据，请将

事件注册表（p，“plotly\u click”）

添加到要从中获取事件数据的绘图（

p

）。 警告：“plotly\u click”事件源ID为“order\u date”未注册。为了获取此事件数据，请将

event\u register（p，“plotly\u click”）

添加到要从中获取事件数据的绘图（

p

）中。”

然后我读到了关于

event\u register（）

的文章，我试图修改代码，但除了破坏它之外，我并没有取得多少成果。 我还尝试使用

highlight（）

为单击的条上色，但我想在本例中我没有正确使用它，因为代码再次中断。你能给我一些关于如何给所选的条和子类别涂上相同颜色的启示吗。非常感谢您抽出时间

库（闪亮）
图书馆（绘本）
图书馆（dplyr）
销售额%
轴标题（）%>%
布局（标题=类别（）
})
产量$销售额%
筛选器（子类别%in%sub_category（））%>%
计数（订单日期，重量=销售额）%>%
绘图（x=~order\u date，y=~n，source=“order\u date”）%>%
添加行（）%>%
轴标题（）%>%
布局（标题=粘贴（子类别（），“随时间的销售”））
})
输出$datatable%
滤器(
%sub_category（）中的sub_category%，
截止日期（订单日期）%中的截止日期（订单日期（））
)
})
}
shinyApp（用户界面、服务器）
给你，伙计，我刚刚根据你点击的内容添加了颜色。


默认情况下，线形图是绿色的，因此我们不必担心它。

对于第一个绘图，如果单击category（），我将改变红色。由于某些原因，我无法直接对其进行变异，因此我在绘图之前创建了一个绘图数据，并使用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)

库（闪亮）
图书馆（绘本）
图书馆（dplyr）
销售额%
阴谋(
x=~sub_category，y=~n，source=“sub_category”，type=“bar”，
标记=列表（颜色=~当前颜色）
) %>%
轴标题（）%>%
布局（标题=类别（）
})
产量$销售额%
筛选器（子类别%in%sub_category（））%>%
计数（订单日期，重量=销售额）%>%
绘图（x=~order\u date，y=~n，source=“order\u date”，line=list（color=“green”））%>%
添加行（）%>%
轴标题（）%>%
布局（标题=粘贴（子类别（），“随时间的销售”））
})
输出$datatable%
滤器(
%sub_category（）中的sub_category%，
截止日期（订单日期）%中的截止日期（订单日期（））
)
})
}
shinyApp（用户界面、服务器）

哇！太棒了！非常感谢你！我认为解决方案隐藏在这个
事件\u data（）
的某个地方，但不一定。你的方法很棒，非常感谢！
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)