2

I am writing a shiny app with a plotly sunburst chart.
After I supply the appropriately formatted dataframe, I have to click on the sunburst chart to "drill-down."

Is is possible to mimic this mouse "click" event to control the "drill-down" from a userinput such as a selectInput() ?

How do I link the selectInput() so that it will also control the shiny sunburst? Perhaps some type of observe event? Thanks for your help.

Here is a reprex:

library(shiny)
library(plotly)
library(DT)


d <- data.frame(
  ids = c(
    "North America", "Europe", "Australia", "North America - Football", "Soccer",
    "North America - Rugby", "Europe - Football", "Rugby",
    "Europe - American Football","Australia - Football", "Association",
    "Australian Rules", "Autstralia - American Football", "Australia - Rugby",
    "Rugby League", "Rugby Union"
  ),
  labels = c(
    "North<br>America", "Europe", "Australia", "Football", "Soccer", "Rugby",
    "Football", "Rugby", "American<br>Football", "Football", "Association",
    "Australian<br>Rules", "American<br>Football", "Rugby", "Rugby<br>League",
    "Rugby<br>Union"
  ),
  parents = c(
    "", "", "", "North America", "North America", "North America", "Europe",
    "Europe", "Europe","Australia", "Australia - Football", "Australia - Football",
    "Australia - Football", "Australia - Football", "Australia - Rugby",
    "Australia - Rugby"
  ),
  stringsAsFactors = FALSE
)


ui <- fluidPage(
  
  mainPanel(
    
    # would like to be able to override or mimic mouse click even with this user input
    selectInput( 
      "make_selection", label = h5("Make selection:"),
      choices = c("all" = " ", setNames(nm = d$ids)),
      selectize = TRUE,
      selected = "all"
    ),
    
    plotlyOutput("p"), 
    textOutput("mytext")
    
    
  )
)

server <- function(input, output, session) {
  
  output$p <- renderPlotly({
    
    plot_ly(d, ids = ~ids, labels = ~labels, parents = ~parents, customdata = ~ids, 
            level = input$make_selection, type = 'sunburst', 
            source = "mysource") 
    
    
    
  })
  
  hoverClick <- reactive({
    currentEventData <- unlist(event_data(event = "plotly_click", source = "mysource", priority = "event"))
  })

  output$mytext <- renderText({

    hoverClick()

  })

  observe({
    x <- input$make_selection

    # Can use character(0) to remove all choices
    if (is.null(hoverClick())){
      x <- "all"
    } else {
      x <- as.character(hoverClick()[3])
    }

    updateSelectInput(session, "make_selection",
                      selected = x
                      
                      # can I add something here so that it just updates the selector without actually
                      # triggering a selector event? (Otherwise both plotly and the selector are trying to
                      # choose the level and it is very jerky)
    )
  })
  
}


shinyApp(ui = ui, server = server)
mdb_ftl
  • 423
  • 2
  • 14

1 Answers1

2

You can use the level argument to specify which level should be shown. My solution below needs work on 2 issues:

  • the change is not animated (maybe you can find a solution with plotly.animate or use it as a starting point)
  • make_selection gets not updated when one clicks on the plot instead (maybe you can play around with the plotly_sunburstclick event to update it
library(shiny)
library(plotly)


d <- data.frame(
  ids = c(
    "North America", "Europe", "Australia", "North America - Football", "Soccer",
    "North America - Rugby", "Europe - Football", "Rugby",
    "Europe - American Football","Australia - Football", "Association",
    "Australian Rules", "Autstralia - American Football", "Australia - Rugby",
    "Rugby League", "Rugby Union"
  ),
  labels = c(
    "North<br>America", "Europe", "Australia", "Football", "Soccer", "Rugby",
    "Football", "Rugby", "American<br>Football", "Football", "Association",
    "Australian<br>Rules", "American<br>Football", "Rugby", "Rugby<br>League",
    "Rugby<br>Union"
  ),
  parents = c(
    "", "", "", "North America", "North America", "North America", "Europe",
    "Europe", "Europe","Australia", "Australia - Football", "Australia - Football",
    "Australia - Football", "Australia - Football", "Australia - Rugby",
    "Australia - Rugby"
  ),
  stringsAsFactors = FALSE
)


ui <- fluidPage(
  
  mainPanel(
    
    # would like to be able to override or mimic mouse click even with this user input
    selectInput( 
      "make_selection", label = h5("Make selection:"),
      choices = c("all" = " ", setNames(nm = d$ids)),
      selectize = TRUE,
      selected = "all"
    ),
    
    plotlyOutput("p")
    
    
  )
)

server <- function(input, output, session) {
  
  output$p <- renderPlotly({
    
    plot_ly(d, ids = ~ids, labels = ~labels, parents = ~parents, 
            level = input$make_selection, type = 'sunburst') %>% 
      event_register("plotly_sunburstclick")
    
    
    
  })
  
  observeEvent(event_data("plotly_sunburstclick"), {
    # get the name of the id and update "make_selection"
  })
}

shinyApp(ui = ui, server = server)
starja
  • 9,887
  • 1
  • 13
  • 28
  • Thank you for your response - please see my edits; I did not know about the "level" parameter in plot_ly(), this works very nicely but as you said the animation does not work and I haven't figured that out yet - I was able to get the data from the click event and feed it back to the selector input - but i would like to update the selector when clicking on plotly without actually triggering a selector event, any ideas? Also, when I drill down to a terminal node, I can't seem to go backwards anymore by clicking on plotly... thanks for your help – mdb_ftl Aug 16 '20 at 16:08
  • you could use a flag to determine if the change in the `selectInput` was due to an update because the user clicked on plotly, or a true change. But then I wouldn't directly use `input$make_selection` in the plotly call, but a reactive, because then it's easier to implement the flag checking – starja Aug 16 '20 at 20:48