通过plotly选择线串几何图形并为其着色

Question

在下面的 Shiny 应用程序中，我想要 2 项改进：

1. 让用户能够使用套索工具轻松选择线条。目前，仅当捕获点时才会捕获线。换句话说，在下面的 GIF 中，我希望这两个选择都能起作用（将线条变成蓝色）。一种解决方案可能是为每条线创建一组点。但有没有更简单的解决方案呢？

2. 为了在

   ggplot()

   以及

   ggplotly()

   之后有效地发生着色。我们可以在

   ggplot()

   之后使用

   ggplot2::annotate()

   来实现这一点，但是对于在

   ggplotly()

   之后进行注释，

   add_segments()

   将无法与关键美学一起使用（在我的情况下需要）。我们收到错误

   unique() applies only to vectors

   。

3. 选择后缩放不会重置。

.dxf 文件位于 此存储库。

闪亮的应用程序：

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

dxf <- st_read(here('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)
  
  output$floor_plot <- renderPlotly({
    dat <- dxf_lns()
    d <- event_data("plotly_selected")
    
    if (!is.null(d)) {
      dat[dat$key %in% d$key, "col"] <- "blue"
    }
    
    p <- ggplot(dat, aes(geometry = geometry, col = I(col), key = key)) +
      geom_sf(data = dat) +
      geom_point(aes(x = xini, y = yini), alpha = 0) +
      theme(axis.title.x = element_blank(), axis.title.y = element_blank())
    
    p |>
      ggplotly() |>
      config(scrollZoom = TRUE) |> 
      event_register("plotly_selected") |>
      layout(dragmode = "lasso")
  })
  
}

shinyApp(ui, server)

注释尝试：

p <- ggplot(dxf_lns, aes(geometry = geometry, key = key,)) +
       geom_sf(data = dxf_lns) +
       geom_point(aes(x = xini, y = yini), alpha = 0) +
       theme(axis.title.x = element_blank(), axis.title.y = element_blank())

pp <- p |> 
  ggplotly() |>
  event_register("plotly_selected") |>
  config(scrollZoom = TRUE) |> 
  layout(dragmode = "lasso", showlegend = FALSE) 

pp |> 
  add_segments(x = 1, xend = 100, y = 1, yend = 100)

Answer 1

一种可能是使用

brushed

事件来代替。您将获得一个点列表，您可以将其转换为几何图形（例如凸包），然后检查哪个几何图形具有交集并为其着色：

server <- function(input, output, session) {
  
  dxf_lns <- reactiveVal(st_as_sf(dxf_lns)) ## make sure dxf_lns stays an sf object
  
  output$floor_plot <- renderPlotly({
    dat <- dxf_lns()
    d <- event_data("plotly_brushed")
    if (!is.null(d)) {
      cvh <- d |>
        do.call(cbind, args = _) |>
        st_multipoint() |>
        st_convex_hull()
      idx <- c(
        st_intersects(cvh, dat, sparse = FALSE)
      ) |>
        which()
      if (length(idx)) {
        dat[idx, "col"] <- "blue"
      }
    }
    p <- ggplot(dat, aes(geometry = geometry, key = key)) +
      geom_sf(data = dat, aes(col = I(col))) +
      geom_point(aes(x = xini, y = yini), alpha = 0) +
      theme(axis.title.x = element_blank(), axis.title.y = element_blank())
    p |>
      ggplotly() |>
      event_register("plotly_brushed") |>
      layout(dragmode = "lasso")
  })
}