Multi level drill down using Plotly in R shiny

Question

I am trying to create a reprodiucible example for three level drill down in R shiny using plotly. I am able to acehive the three level drill down but the back button appears before I start the drill down and I am not able to get rid of it. That is the back button appears before I even start the drill down. Below is the Minimal Working Example. Any help is appreciated. Thanks

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")
)

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({
    d <- count(sales_data(), value, wt = sales)

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

    if (!length(drills$sub_category)) {
      add_bars(p, color = ~value)
    } else if (!length(drills$id)) {
      add_bars(p) %>%
        layout(
          hovermode = "x",
          xaxis = list(showticklabels = FALSE)
        )
    } else {
      # add a visual cue of which ID is selected
      add_bars(p) %>%
        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 (!length(drills$sub_category)) 
   actionButton("clear", "Back", icon("chevron-left"))

  })

  output$back1 <- renderUI({
    if (length(drills$sub_category)) 
      actionButton("clear1", "Back", icon("chevron-left"))

  })

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

}

shinyApp(ui, server)

Answer 1

Thanks for providing this well structured reproducible example.

You were simply missing a second condition for your "back" renderUI call.

Please check the following:

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")
)

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({
    d <- count(sales_data(), value, wt = sales)
    
    p <- plot_ly(d,
                 x = ~ value,
                 y = ~ n,
                 source = "bars") %>%
      layout(yaxis = list(title = "Total Sales"),
             xaxis = list(title = ""))
    
    if (!length(drills$sub_category)) {
      add_bars(p, color = ~ value)
    } else if (!length(drills$id)) {
      add_bars(p) %>%
        layout(hovermode = "x",
               xaxis = list(showticklabels = FALSE))
    } else {
      # add a visual cue of which ID is selected
      add_bars(p) %>%
        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)
  
}

shinyApp(ui, server)