使用闪亮的用户输入触发鼠标单击事件

Question

我正在编写一个闪亮的应用程序，其中包含一个绘制的旭日形图。
提供适当格式的数据框后，我必须单击旭日形图以“向下钻取”。

是否可以模仿这个鼠标“点击”事件来控制来自用户输入的“向下钻取”，例如 selectInput() ？

如何链接 selectInput() 以便它也可以控制闪亮的旭日形？也许某种类型的观察事件？感谢您的帮助。

这是一个代表：

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 参数来指定应显示的级别。我的以下解决方案需要解决 2 个问题：

• 更改没有动画效果（也许您可以使用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)