I am creating a drilldown plot and I am basing my solution on the excellent example provided here. I have reproduced it below. This works great except that when you drilldown into the plot and then click back, and then select the same bar again it doesn’t drill back down. However, if you select a different bar it does drill down again. I’m guessing that the observeEvent(event_data("plotly_click", source = "bars"), {...
part doesn’t register a click if the clicked item was the same as the last time. Is there a way to get it to recognise the same bar being clicked?
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)