Shiny应用实现鼠标悬停获取绘图数据点详情求助

嘿，好消息！Shiny完全支持给绘图数据点添加悬停显示详情的功能，我给你分享几个实用的实现方案，你可以根据自己的需求来选：

Plotly和Shiny适配性极佳，只需要把你的ggplot对象转换成Plotly对象，就能自动生成悬停提示，还能自定义提示内容。

修改后的UI代码片段 #

tabItem(tabName = "models2", 
        fluidPage( 
          fluidRow( infoBoxOutput("overview") ), 
          fluidRow( 
            actionButton("result1","Generate Result"), 
            downloadButton('downloadPlot', 'Download Plot')
          ),
          # 替换原plotOutput为plotlyOutput
          fluidRow(plotlyOutput("myInteractivePlot"))
        )
)

对应的Server代码片段 #

server <- function(input, output) {
  # 假设你的绘图数据是点击按钮后生成的，这里用示例数据模拟
  plot_data <- reactive({
    input$result1  # 触发绘图更新的按钮
    isolate({
      data.frame(
        x = rnorm(50),
        y = rnorm(50),
        point_id = paste("数据点", 1:50),
        value = round(runif(50, 0, 100), 2)
      )
    })
  })

  # 生成带悬停的Plotly图
  output$myInteractivePlot <- renderPlotly({
    p <- ggplot(plot_data(), aes(x = x, y = y, 
                                 # 自定义悬停显示的内容，用<br>换行
                                 text = paste("ID:", point_id, "<br>数值:", value))) +
      geom_point(size = 3)
    # 转换为Plotly对象，指定只显示自定义的text内容
    ggplotly(p, tooltip = "text")
  })

  # 保留原有的下载功能，也可以适配Plotly导出交互HTML
  output$downloadPlot <- downloadHandler(
    filename = function() { paste("plot_", Sys.Date(), ".png", sep="") },
    content = function(file) {
      # 用ggplot生成静态图下载
      p <- ggplot(plot_data(), aes(x = x, y = y)) + geom_point()
      ggsave(file, plot = p, device = "png")
      # 如果要下载交互版HTML，替换成下面一行：
      # htmlwidgets::saveWidget(ggplotly(p), file = paste0(file, ".html"))
    }
  )
}

如果你想留在ggplot的生态里，ggiraph包专门用来给ggplot添加交互元素，包括悬停提示。

修改后的UI代码片段 #

tabItem(tabName = "models2", 
        fluidPage( 
          fluidRow( infoBoxOutput("overview") ), 
          fluidRow( 
            actionButton("result1","Generate Result"), 
            downloadButton('downloadPlot', 'Download Plot')
          ),
          # 替换为ggiraphOutput
          fluidRow(ggiraphOutput("myInteractivePlot"))
        )
)

对应的Server代码片段 #

server <- function(input, output) {
  plot_data <- reactive({
    input$result1
    isolate({
      data.frame(
        x = rnorm(50),
        y = rnorm(50),
        point_id = paste("数据点", 1:50),
        value = round(runif(50, 0, 100), 2)
      )
    })
  })

  output$myInteractivePlot <- renderggiraph({
    p <- ggplot(plot_data(), aes(x = x, y = y)) +
      # 用geom_point_interactive替换普通geom_point，自定义tooltip
      geom_point_interactive(
        aes(tooltip = paste("ID:", point_id, "\n数值:", value)),
        size = 3
      )
    # 转换为可交互的ggiraph对象
    girafe(ggobj = p)
  })

  # 下载功能和之前一致
  output$downloadPlot <- downloadHandler(
    filename = function() { paste("plot_", Sys.Date(), ".png", sep="") },
    content = function(file) {
      p <- ggplot(plot_data(), aes(x = x, y = y)) + geom_point()
      ggsave(file, plot = p, device = "png")
    }
  )
}

如果不想依赖第三方包，可以用Shiny原生的hoverOpts来捕获鼠标位置，再计算最近的数据点并显示详情，不过这个方案代码稍复杂。

修改后的UI代码片段 #

tabItem(tabName = "models2", 
        fluidPage( 
          fluidRow( infoBoxOutput("overview") ), 
          fluidRow( 
            actionButton("result1","Generate Result"), 
            downloadButton('downloadPlot', 'Download Plot')
          ),
          fluidRow(
            # 添加hover参数捕获悬停事件
            plotOutput("myPlot", hover = hoverOpts(id = "plot_hover", delay = 100))
          ),
          # 用于显示悬停详情的UI
          fluidRow(uiOutput("hoverDetails"))
        )
)

对应的Server代码片段 #

server <- function(input, output) {
  plot_data <- reactive({
    input$result1
    isolate({
      data.frame(
        x = rnorm(50),
        y = rnorm(50),
        point_id = paste("数据点", 1:50),
        value = round(runif(50, 0, 100), 2)
      )
    })
  })

  output$myPlot <- renderPlot({
    ggplot(plot_data(), aes(x = x, y = y)) + geom_point(size = 3)
  })

  # 获取悬停位置对应的最近数据点
  hovered_point <- reactive({
    req(input$plot_hover)
    # 匹配最近的点，threshold控制触发距离
    nearPoints(plot_data(), input$plot_hover, threshold = 15, maxpoints = 1)
  })

  # 渲染悬停详情
  output$hoverDetails <- renderUI({
    req(hovered_point())
    point <- hovered_point()
    wellPanel(
      h5("数据点详情"),
      paste("ID:", point$point_id),
      br(),
      paste("数值:", point$value)
    )
  })

  # 下载功能保留
  output$downloadPlot <- downloadHandler(
    filename = function() { paste("plot_", Sys.Date(), ".png", sep="") },
    content = function(file) {
      p <- ggplot(plot_data(), aes(x = x, y = y)) + geom_point()
      ggsave(file, plot = p, device = "png")
    }
  )
}

这三个方案里，前两种（Plotly/ggiraph）上手最快，交互体验也更好，推荐优先尝试。

内容的提问来源于stack exchange，提问作者Mikz