javascript - 使用 Shiny 的用户输入触发鼠标单击事件

Question

我正在编写一个 Shiny 的应用程序，其中包含一个精心设计的森伯斯特图表。
在我提供了适当格式的数据框之后，我必须点击旭日图来“向下钻取”。
是否可以模仿这个鼠标“单击”事件来控制来自用户输入的“向下钻取”，例如 selectInput() ？
如何链接 selectInput() 以便它也可以控制 Shiny 的旭日？也许某种类型的观察事件？谢谢你的帮助。
这是一个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)

Answer 1

您可以使用 level参数来指定应该显示哪个级别。我下面的解决方案需要解决两个问题:

更改不是动画的(也许您可以使用 plotly.animate 找到解决方案或将其用作起点)

make_selection当单击绘图时不会更新(也许你可以玩 plotly_sunburstclick 事件来更新它

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)