如何为R Shiny中的ggplot散点图添加鼠标滚轮/双击缩放功能？

你当前的代码用renderImage生成静态PNG图片，这类静态输出无法支持鼠标滚轮/双击缩放的交互功能。之前尝试plotly失败大概率是因为没有正确替换渲染逻辑，下面提供两种可行的方案：

方案一：使用plotly实现交互缩放 #

修改步骤： #

1. 安装并加载plotly包
2. 将静态ggplot对象转换为plotly交互式对象
3. 替换UI和Server中的渲染组件为plotly对应的接口

修改后的完整代码： #

library(shiny)
library(ggplot2)
library(dplyr)
library(plotly) # 新增加载plotly

ui = fluidPage(
  
  br(),
  
  fluidRow(
    
    column(width = 2, 
           varSelectInput("variablex", "Trait x:", iris[1:4]),
           varSelectInput("variabley", "Trait y:", iris[1:4]),
           varSelectInput("variabledot", "Trait dot size:", iris[1:4]),
           
           textInput(
             inputId ="plotdim"
             , label = "Dimensions (W*H*dpi)"
             , placeholder = "W*H*dpi"
             , value = "35*25*100"
           ),
           
           br(),
           
           downloadButton("download_pdf", "Download as PDF")
    ),
    
    column(width = 10,   
           # 替换imageOutput为plotlyOutput
           plotlyOutput("plot", height = "800px") # 可自定义高度
    )
    
  ),
)


server = function(input, output) {

  culturename<-"Iris"
  Speciesname<-iris$Species[1]

  # plot reactive：生成ggplot对象后用ggplotly转换为plotly
  plot <- reactive({
    p <- ggplot(iris, aes(x=!!input$variablex, y=!!input$variabley)) +
      geom_point(aes(size=!!input$variabledot), pch=21) +
      theme_grey(base_size = 22) +
      theme(legend.position = "right") +
      guides(fill = guide_legend(override.aes = list(size=3)))
    
    # 转换为plotly对象，默认支持滚轮缩放、双击复位
    ggplotly(p) %>% 
      layout(dragmode = "zoom") # 设置拖拽模式为缩放，也可选"pan"拖拽
  })
  
  # 替换renderImage为renderPlotly
  output$plot <- renderPlotly({
    plot()
  })
  
  # 保留原有的PDF下载功能
  output$download_pdf <- downloadHandler(
    filename = function(){
      paste(culturename,"_",Speciesname,".pdf",sep="")
    },
    content = function(file){
      pdf(file, width = 20, height = 13)
      print(ggplot(iris, aes(x=!!input$variablex, y=!!input$variabley)) +
              geom_point(aes(size=!!input$variabledot), pch=21) +
              theme_grey(base_size = 22) +
              theme(legend.position = "right") +
              guides(fill = guide_legend(override.aes = list(size=3))))
      dev.off()
    }
  )
}

shinyApp(ui = ui, server = server)

关键改动说明： #

• 替换imageOutput为plotlyOutput，renderImage为renderPlotly
• 用ggplotly()将ggplot对象转换为交互式plotly图表，默认支持鼠标滚轮缩放、双击复位，还可通过layout(dragmode="zoom")开启拖拽缩放
• PDF下载部分重新生成静态ggplot对象，保证导出的是矢量图

方案二：使用ggiraph实现交互缩放 #

如果更倾向于贴近ggplot原生语法的交互工具，可以用ggiraph：

修改后的完整代码： #

library(shiny)
library(ggplot2)
library(dplyr)
library(ggiraph) # 新增加载ggiraph

ui = fluidPage(
  
  br(),
  
  fluidRow(
    
    column(width = 2, 
           varSelectInput("variablex", "Trait x:", iris[1:4]),
           varSelectInput("variabley", "Trait y:", iris[1:4]),
           varSelectInput("variabledot", "Trait dot size:", iris[1:4]),
           
           textInput(
             inputId ="plotdim"
             , label = "Dimensions (W*H*dpi)"
             , placeholder = "W*H*dpi"
             , value = "35*25*100"
           ),
           
           br(),
           
           downloadButton("download_pdf", "Download as PDF")
    ),
    
    column(width = 10,   
           # 替换为ggiraphOutput
           ggiraphOutput("plot", height = "800px")
    )
    
  ),
)


server = function(input, output) {

  culturename<-"Iris"
  Speciesname<-iris$Species[1]

  # plot reactive：用ggiraph包装ggplot
  plot <- reactive({
    p <- ggplot(iris, aes(x=!!input$variablex, y=!!input$variabley)) +
      geom_point_interactive(aes(size=!!input$variabledot), pch=21) # 替换geom_point为交互式版本
      theme_grey(base_size = 22) +
      theme(legend.position = "right") +
      guides(fill = guide_legend(override.aes = list(size=3)))
    
    # 开启缩放、拖拽功能
    ggiraph(code = print(p), 
            zoom_max = 5, # 设置最大缩放倍数
            zoom_min = 0.2, # 设置最小缩放倍数
            hover_css = "cursor:zoom-in;")
  })
  
  # 替换renderImage为renderggiraph
  output$plot <- renderggiraph({
    plot()
  })
  
  # 保留PDF下载功能
  output$download_pdf <- downloadHandler(
    filename = function(){
      paste(culturename,"_",Speciesname,".pdf",sep="")
    },
    content = function(file){
      pdf(file, width = 20, height = 13)
      print(ggplot(iris, aes(x=!!input$variablex, y=!!input$variabley)) +
              geom_point(aes(size=!!input$variabledot), pch=21) +
              theme_grey(base_size = 22) +
              theme(legend.position = "right") +
              guides(fill = guide_legend(override.aes = list(size=3))))
      dev.off()
    }
  )
}

shinyApp(ui = ui, server = server)

关键改动说明： #

• 替换geom_point为geom_point_interactive，用ggiraph()包装ggplot对象
• 通过zoom_max和zoom_min控制缩放范围，支持鼠标滚轮缩放、拖拽平移，双击可复位
• PDF下载需重新生成静态ggplot对象，保证导出效果

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