将鼠标悬停在Shiny中的元素上时如何更改图形？

Question

我正在寻找一种解决方案，当用户将鼠标悬停在同一面板中的超链接上时，可以更改Shiny应用中的绘图。这是一个简单的例子：

library(shiny)

words <- sort(sapply(1:50, USE.NAMES = F, FUN = function (x) paste(sample(letters, 15), collapse = "")), decreasing = T)

dat <- data.frame(words, f = sort(rgamma(50, shape = 5, scale = 1)))

ui <- pageWithSidebar(
  headerPanel("Playground"),
  sidebarPanel(),
  mainPanel(
    uiOutput("links"),
    plotOutput("out.plot")
  )
)

server <- function(input, output, session) {
  urls <- lapply(dat$words, FUN = function (x) {
    a(paste0(" ", x, " "),
      href = paste0("https://", x, ".de"),
      target = "_blank")
  })
  output$links <- renderUI({
    tagList(urls)
  })
  output$out.plot <- renderPlot({
    ggplot(dat, aes(x = words, y = f)) +
      geom_bar(stat = "identity") +
      theme(axis.text.x = element_text(angle = 90))
  })
}

shinyApp(ui, server)

在这个例子中，每当我将鼠标悬停在情节上方的超链接（示例中的超链接或无意义，但这不是问题）时，我想突出显示ggplot的一个条（例如，更改其颜色）。正如您在示例中所看到的，所有条形都与一个超链接“关联”。

解决方案应该是非常敏感的（即快速）。也许，情节剧情可以帮助吗？我不太清楚地说道。

我没有任何JavaScript经验。我很想了解解决方案，如果涉及任何JavaScript，请尝试广泛评论。非常感谢！

我附上了应用的屏幕截图，因此如果您不想，则无需运行示例代码。

Answer 1

shinyjs包可以真正简化这些事情。我们可以使用onevent函数和“mouseenter”作为参数来捕获这些事件。为了使它工作，我们必须给元素一个id，或者将它们包装在一个我们可以引用的id的div中。然后，我们可以使用它们来更新包含当前悬停元素的reactiveVal，而后者又用于reactive，用于修改要绘制的data.frame。我们也可以通过收听“mouseleave”事件来重置reactiveVal。

我希望这有帮助！

library(shiny)
library(shinyjs)
library(dplyr)
library(ggplot2)

set.seed(1)
words <- sort(sapply(1:50, USE.NAMES = F, FUN = function (x) paste(sample(letters, 15), collapse = "")), decreasing = T)

dat <- data.frame(words, f = sort(rgamma(50, shape = 5, scale = 1)),stringsAsFactors = F)

ui <- pageWithSidebar(
  headerPanel("Playground"),
  sidebarPanel(),
  mainPanel(
    uiOutput("links"),
    plotOutput("out.plot"),
    useShinyjs()
  ))

server <- function(input, output, session) {
  urls <- lapply(dat$words, FUN = function (x) {
    div(id=x, a(paste0(" ", x, " "),
      href = paste0("https://", x, ".de"),
      target = "_blank"))
  })
  output$links <- renderUI({
    tagList(urls)
  })

  # Add a reactieVal that we can update once an object is hovered.
  hovered_element <- reactiveVal('')

  # Add onevent for each element in dat$words, to update reactiveVal.
  lapply(dat$words,function(x){
    onevent(event='mouseleave',id=x,hovered_element(''))
    onevent(event='mouseenter',id=x,hovered_element(x))
  })

  # Add a reactive for the dataset, which we debounce so it does not invalidate too often.
  my_data <- reactive({    
    dat$color <- ifelse(dat$words==hovered_element(),'hovered','')
    dat
  })
  my_data <- my_data %>% debounce(50) # tune for responsiveness

  # Plot
  output$out.plot <- renderPlot({
    ggplot(my_data(), aes(x = words, y = f,fill=color)) +
      geom_bar(stat = "identity") +
      theme(axis.text.x = element_text(angle = 90)) + theme(legend.position="none")
  })
}

shinyApp(ui, server)