如何在rShiny中展示带可点击链接的ggplot SVG并保留交互功能？

背景与现状 #

我在Shiny项目里需要展示ggplot生成的SVG，这个SVG的Y轴标签嵌入了超链接。一开始用plotOutput实现不了，换成imageOutput+renderImage后能正常显示SVG，但里面的超链接完全点不动。

现有代码如下：

renderImage({
            d = dataForHeatmap()
            p = ggplot(d,aes(x=x,y=y,fill=some_fill)) + geom_tile(colour="white", linewidth=0.25)
            width  <- session$clientData$output_heatData_width
            height <- session$clientData$output_heatData_height
            ratio = width/height
            
            tf1 <- tempfile(fileext = ".svg")
            ggsave( tf1 , p, width=7*ratio,height=7)
            
            xml <- read_xml(tf1)
            xml %>%
              xml_find_all(xpath="//d1:text") %>% 
              keep(xml_text(.) %in% names(links)) %>% 
              xml_add_parent("a", "xlink:href" = "https://www.youtube.com/watch?v=j8PxqgliIno", target = "_blank")
            write_xml(xml, tf2 <- tempfile(fileext = ".svg"))
            
            return(list(src = normalizePath(tf2), width = width, height = height, contentType = "image/svg+xml", alt="Histogram"))
    }, deleteFile = TRUE)

问题根源 #

这是因为renderImage会把SVG包裹在<img>标签里，浏览器会把img里的SVG当作位图资源处理，直接忽略里面的交互元素（比如超链接）。

需求矛盾 #

查到的常规方案是改用uiOutput直接输出原始SVG代码，这样超链接能正常点击，但我还在使用imageOutput自带的click、dblclick和hover交互功能，不想重新实现这部分逻辑。

兼顾方案：直接输出SVG+手动绑定交互事件 #

下面是不用完全重构交互逻辑的解决方案：

1. 修改服务器端：用renderUI输出SVG元素 #

把原来的renderImage替换成renderUI，直接生成SVG字符串并嵌入页面，而不是通过img标签引用：

output$heatData <- renderUI({
  d <- dataForHeatmap()
  p <- ggplot(d, aes(x=x, y=y, fill=some_fill)) + geom_tile(colour="white", linewidth=0.25)
  width  <- session$clientData$output_heatData_width
  height <- session$clientData$output_heatData_height
  ratio <- width/height
  
  tf1 <- tempfile(fileext = ".svg")
  ggsave(tf1, p, width=7*ratio, height=7)
  
  xml <- read_xml(tf1)
  xml %>%
    xml_find_all(xpath="//d1:text") %>% 
    keep(xml_text(.) %in% names(links)) %>% 
    xml_add_parent("a", "xlink:href" = "https://www.youtube.com/watch?v=j8PxqgliIno", target = "_blank")
  
  # 将XML对象转为字符串
  svg_str <- as.character(xml)
  
  # 用div容器包裹SVG，设置宽高并给SVG加ID用于绑定事件
  tags$div(
    tags$svg(
      HTML(svg_str),
      id = "interactive-svg",
      width = width,
      height = height
    ),
    style = paste0("width: ", width, "px; height: ", height, "px;")
  )
})

2. 在UI中添加JS绑定交互事件 #

用JavaScript给SVG元素手动绑定click、dblclick和hover事件，把事件坐标传给Shiny的input对象，模拟imageOutput的交互效果：

ui <- fluidPage(
  uiOutput("heatData"),
  tags$script(HTML("
    $(document).on('shiny:connected', function() {
      const svg = document.getElementById('interactive-svg');
      
      // 绑定点击事件
      svg.addEventListener('click', function(e) {
        const rect = svg.getBoundingClientRect();
        const x = e.clientX - rect.left;
        const y = e.clientY - rect.top;
        Shiny.setInputValue('heatData_click', {x: x, y: y});
      });
      
      // 绑定双击事件
      svg.addEventListener('dblclick', function(e) {
        const rect = svg.getBoundingClientRect();
        const x = e.clientX - rect.left;
        const y = e.clientY - rect.top;
        Shiny.setInputValue('heatData_dblclick', {x: x, y: y});
      });
      
      // 绑定鼠标悬浮事件
      svg.addEventListener('mousemove', function(e) {
        const rect = svg.getBoundingClientRect();
        const x = e.clientX - rect.left;
        const y = e.clientY - rect.top;
        Shiny.setInputValue('heatData_hover', {x: x, y: y});
      });
      
      // 鼠标离开时清空悬浮输入
      svg.addEventListener('mouseleave', function() {
        Shiny.setInputValue('heatData_hover', null);
      });
    });
  "))
)

3. 复用原有交互逻辑 #

现在服务器端可以像之前使用imageOutput时一样，监听input$heatData_click、input$heatData_dblclick、input$heatData_hover这些输入，原有交互逻辑几乎不用修改。

注意事项 #

• 如果SVG的xpath查询出现问题，可能需要显式定义命名空间，比如给xml_find_all加上ns = xml_ns(xml)参数；
• 确保SVG的宽高设置和原来一致，避免显示变形。

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