基于Plotly的Shiny应用线串几何选择与着色优化需求

优化需求 #

• 核心优先级：支持套索工具直接框选线串，选中后标记为蓝色（原仅支持选中点对应的线串）
• 解决ggplotly()后使用add_segments()时的unique() applies only to vectors报错，实现高效着色
• 选择操作后保留当前缩放状态，不重置

解决方案代码 #

library(tidyverse)
library(plotly)
library(shiny)
library(reactable)
library(sf)
library(lwgeom)
library(bslib)

# 读取DXF数据
dxf <- st_read("d3map/giraffe360_demo_residential.dxf")

dxf_gp <- dxf |> 
  group_by(geometry_type = st_geometry_type(dxf)) |>
  nest()

dxf_lns <- dxf_gp |> 
  filter(geometry_type == "LINESTRING") |> 
  unnest(cols = c(data)) |> 
  mutate(
    geometry = st_zm(geometry, "LINESTRING"),
    ini = st_startpoint(geometry),
    end = st_endpoint(geometry)
  )

dxf_lns <- dxf_lns |> 
  mutate(
    across(
      c(ini, end),
      list(
        x = \(point) st_coordinates(point)[,1],
        y = \(point) st_coordinates(point)[,2]
      ),
      .names = "{.fn}{.col}"
    )
  )

dxf_lns$key <- row.names(dxf_lns)
dxf_lns$col <- "black"

ui <- bslib::page_fluid(
  plotlyOutput("floor_plot")
)

server <- function(input, output, session) {
  # 存储线串数据与缩放状态
  dxf_lns <- reactiveVal(dxf_lns)
  plot_layout <- reactiveVal(list())
  
  output$floor_plot <- renderPlotly({
    dat <- dxf_lns()
    d <- event_data("plotly_selected")
    
    # 更新选中线串的颜色
    if (!is.null(d)) {
      # 提取选中的key（直接从线串trace获取，不再依赖透明点）
      selected_keys <- unique(d$key)
      dat$col <- ifelse(dat$key %in% selected_keys, "blue", "black")
      dxf_lns(dat)
    }
    
    p <- ggplot(dat, aes(col = I(col))) +
      geom_sf(aes(key = key), data = dat) + # 将key绑定到线串本身
      theme(axis.title.x = element_blank(), axis.title.y = element_blank())
    
    pp <- p |>
      ggplotly(tooltip = FALSE) |>
      config(scrollZoom = TRUE) |>
      event_register("plotly_selected") |>
      layout(dragmode = "lasso")
    
    # 恢复之前的缩放状态
    if (length(plot_layout()) > 0) {
      pp <- pp |> layout(xaxis = plot_layout()$xaxis, yaxis = plot_layout()$yaxis)
    }
    
    # 监听缩放/平移事件，保存布局状态
    pp |> onRender("
      function(el, x) {
        el.on('plotly_relayout', function(eventData) {
          Shiny.setInputValue('plot_layout', eventData);
        });
      }
    ")
  })
  
  # 保存缩放布局状态
  observeEvent(input$plot_layout, {
    plot_layout(input$plot_layout)
  })
}

shinyApp(ui, server)

问题解决说明 #

1. 套索直接选线串 #

原代码将key绑定到透明点，导致只有选中点才能触发线串选择。修改后：

• 将key美学直接绑定到geom_sf的线串上，让线串本身成为选择对象
• 从event_data("plotly_selected")中直接提取线串的key，更新对应颜色

2. 解决add_segments()报错 #

原代码中ggplot()全局绑定了key美学，导致后续add_segments()继承该美学引发冲突。修改后：

• 将key美学从全局ggplot()移到geom_sf()内部，仅线串使用key
• 后续调用add_segments()时不再受全局key影响，示例代码可正常运行：

# 修复后的add_segments调用示例
pp <- ggplot(dat, aes(col = I(col))) +
  geom_sf(aes(key = key), data = dat) +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank()) |>
  ggplotly(tooltip = FALSE) |>
  config(scrollZoom = TRUE) |>
  layout(dragmode = "lasso")

pp |> add_segments(x = 1, xend = 100, y = 1, yend = 100, line = list(color = "red"))

3. 保留缩放状态 #

通过plotly_relayout事件监听布局变化，将缩放、平移状态保存到reactiveVal中，每次重新渲染图表时恢复之前的x轴、y轴布局参数，避免重置。

内容的提问来源于stack exchange，提问作者its.me.adam