rshinydrilldown

Click event in drill down plots


I'm trying to use click events using the plotly_click option in RShiny. What I want to do is: On clicking the plot, the dataset corresponding to the click event is displayed. So when I click on 'Office Supplies' in categories on the plot, dataset corresponding to category column='Office Supplies' is displayed. Similarly, when I drill down to sub category level and click on any of sub category in the plot, dataset corresponding to the sub category is displayed. But what I am not able to achieve is: that when I click on 'Back' action button, I see an empty data table and not data table corresponding to key 'Office Supplies' i.e. On clicking the back button, I see an empty table which is what I don't want. How should I do this?. Any help would be appreciated. Below is my code:

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(), value, 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", "Back", 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)

Solution

  • As you did not provide sample data, I used gapminder data to test. When you click on 'back' button for sub_category, it is not recognizing the click event on the plot. Alternately, you can just output sales_data() as shown below.

    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(), value, 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", "Back", 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)