钻取图中的点击事件

问题描述

我正在尝试使用 RShiny 中的 plotly_click 选项来使用点击事件。我想要做的是：单击绘图时，显示与单击事件对应的数据集。因此，当我单击图上类别中的“办公用品”时，会显示与类别 column='Office Supplies' 对应的数据集。同样，当我深入到子类别级别并单击图中的任何子类别时，会显示与子类别对应的数据集。但我无法实现的是：当我点击“后退”操作按钮时，我看到一个空的数据表，而不是与关键“办公用品”对应的数据表，即单击后退按钮时，我看到一个空表这是我不想要的。我该怎么做？。任何帮助，将不胜感激。下面是我的代码：

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

sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")
categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)

ui <- fluidPage(
  uIoUtput("history"),plotlyOutput("bars",height = 200),plotlyOutput("lines",height = 300),uIoUtput('back'),uIoUtput("back1"),dataTableOutput("click1")
)

server <- function(input,output,session) {
  # These reactive values keep track of the drilldown state
  # (NULL means inactive)
  drills <- reactiveValues(category = NULL,sub_category = NULL,id = NULL)
  # filter the data based on active drill-downs
  # also create a column,value,which keeps track of which
  # variable we're interested in
  sales_data <- reactive({
    if (!length(drills$category)) {
      return(mutate(sales,value = category))
    }
    sales <- filter(sales,category %in% drills$category)
    if (!length(drills$sub_category)) {
      return(mutate(sales,value = sub_category))
    }
    sales <- filter(sales,sub_category %in% drills$sub_category)
    mutate(sales,value = id)
  })

  # bar chart of sales by 'current level of category'
  output$bars <- renderPlotly({
    a<- sales
    render_value(a)
    d <- count(sales_data(),wt = sales)

    p <- plot_ly(d,x = ~ value,y = ~ n,source = "bars",key=~value) %>%
      layout(yaxis = list(title = "Total Sales"),xaxis = list(title = ""))

    if (!length(drills$sub_category)) {
      add_bars(p,color = ~ value,key=~value)
    } else if (!length(drills$id)) {
      add_bars(p,key=~value) %>%
        layout(hovermode = "x",xaxis = list(showticklabels = FALSE))
    } else {
      # add a visual cue of which ID is selected
      add_bars(p,key=~value) %>%
        filter(value %in% drills$id) %>%
        add_bars(color = I("black")) %>%
        layout(
          hovermode = "x",xaxis = list(showticklabels = FALSE),showlegend = FALSE,barmode = "overlay"
        )
    }
  })


  # control the state of the drilldown by clicking the bar graph
  observeEvent(event_data("plotly_click",source = "bars"),{
    x <- event_data("plotly_click",source = "bars")$x
    if (!length(x))
      return()

    if (!length(drills$category)) {
      drills$category <- x
    } else if (!length(drills$sub_category)) {
      drills$sub_category <- x
    } else {
      drills$id <- x
    }
  })

  output$back <- renderUI({
    if (!is.null(drills$category) && is.null(drills$sub_category)) {
      actionButton("clear","Back",icon("chevron-left"))
    }
  })

  output$back1 <- renderUI({
    if (!is.null(drills$sub_category)) {
      actionButton("clear1",icon("chevron-left"))
    }
  })

  observeEvent(input$clear,drills$category <- NULL)
  observeEvent(input$clear1,drills$sub_category <- NULL)

  render_value=function(df_1){
    output$click1<- DT::renderDataTable({
      s <- event_data("plotly_click",source="bars")
      if (is.null(s)){
        return(NULL)
      }
      else if(!is.null(drills$category) && is.null(drills$sub_category)){
        ad<- df_1[df_1$category %in% s$key,]
        return(DT::datatable(ad))
      }
      else if(!is.null(drills$sub_category)){
        print(s$key)
        ad<- df_1[df_1$sub_category %in% s$key,]
        return(DT::datatable(ad))
      }
    })
  }

}

shinyApp(ui,server)

解决方法

由于您没有提供示例数据，我使用 gapminder 数据进行测试。当您单击 sub_category 的“后退”按钮时，它无法识别绘图上的单击事件。或者，您可以只输出 sales_data()，如下所示。

library(shiny)
library(plotly)
library(dplyr)
library(readr)
library(gapminder)

#sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")

sales <- gapminder
sales$category <- sales$continent
sales$sub_category <- sales$country
sales$id <- sales$year
sales$n <- sales$lifeExp
sales$sales <- sales$gdpPercap

categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)

ui <- fluidPage(
  
  # uiOutput("history"),plotlyOutput("bars",height = 200),# plotlyOutput("lines",height = 300),uiOutput('back'),uiOutput("back1"),DTOutput("t1")       ## working,DTOutput("click1")  ## not working
)

server <- function(input,output,session) {
  # These reactive values keep track of the drilldown state
  # (NULL means inactive)
  drills <- reactiveValues(category = NULL,sub_category = NULL,id = NULL)
  # filter the data based on active drill-downs
  # also create a column,value,which keeps track of which
  # variable we're interested in
  sales_data <- reactive({
    if (!length(drills$category)) {
      return(mutate(sales,value = category))
    }
    sales <- filter(sales,category %in% drills$category)
    if (!length(drills$sub_category)) {
      return(mutate(sales,value = sub_category))
    }
    sales <- filter(sales,sub_category %in% drills$sub_category)
    mutate(sales,value = id)
  })
  
  output$t1 <- renderDT({
    if (is.null(drills$category) & is.null(drills$sub_category) ) return(NULL)  ## comment out this line if you want all data to be displayed initially
    sales_data()
  })
  
  # bar chart of sales by 'current level of category'
  output$bars <- renderPlotly({
    a<- sales
    render_value(a)
    d <- count(sales_data(),wt = sales)

    p <- plot_ly(d,x = ~ value,y = ~ n,source = "bars",key=~value) %>%
      layout(yaxis = list(title = "Total Sales"),xaxis = list(title = ""))

    if (!length(drills$sub_category)) {
      add_bars(p,color = ~ value,key=~value)
    } else if (!length(drills$id)) {
      add_bars(p,key=~value) %>%
        layout(hovermode = "x",xaxis = list(showticklabels = FALSE))
    } else {
      # add a visual cue of which ID is selected
      add_bars(p,key=~value) %>%
        filter(value %in% drills$id) %>%
        add_bars(color = I("black")) %>%
        layout(
          hovermode = "x",xaxis = list(showticklabels = FALSE),showlegend = FALSE,barmode = "overlay"
        )
    }
  })


  # control the state of the drilldown by clicking the bar graph
  observeEvent(event_data("plotly_click",source = "bars"),{
    x <- event_data("plotly_click",source = "bars")$x
    if (!length(x))
      return()

    if (!length(drills$category)) {
      drills$category <- x
    } else if (!length(drills$sub_category)) {
      drills$sub_category <- x
    }else {
      drills$id <- x
    }
    
  })

  output$back <- renderUI({
    if (!is.null(drills$category) && is.null(drills$sub_category)) {
      actionButton("clear","Back",icon("chevron-left"))
    }
  })

  output$back1 <- renderUI({
    if (!is.null(drills$sub_category)) {
      actionButton("clear1",icon("chevron-left"))
    }
  })

  observeEvent(input$clear,{drills$category <- NULL})
  observeEvent(input$clear1,{
               drills$sub_category <- NULL})

  render_value=function(df_1){
    output$click1<- DT::renderDataTable({
      s <- event_data("plotly_click",source="bars")
      if (is.null(s)){
        return(NULL)
      }else if((!is.null(drills$category) && is.null(drills$sub_category))){
        print(s$key)
        ad<- df_1[df_1$category %in% s$key,]
        return(DT::datatable(ad))
      }else if(!is.null(drills$sub_category)){
        #print(s$key)
        ad<- df_1[df_1$sub_category %in% s$key,]
        return(DT::datatable(ad))
      }
    })
  }
  
}

shinyApp(ui,server)