R Shiny实现DT表格选中条目在交互式地图高亮的问题

问题场景 #

开发一款允许用户添加公共果树位置的Shiny应用，需求是：用户选中DT数据表中的条目时，tmap地图上对应的点单独高亮（修改其大小、透明度等样式），其余点保持原有样式。原代码尝试判断选中条目后生成新地图，导致原地图被替换，仅显示选中点，不符合需求。

解决方案 #

核心是将高亮图层叠加在原地图之上，而非替换原地图。修改renderTmap中的逻辑，在原地图基础上添加选中点的高亮图层：

library(dplyr)
library(shiny)
library(leaflet)
library(tmap)
library(sf)
library(mapview)


# 初始数据集
dat <- data.frame(lat = c(48.7323,48.7308,
                          48.7301,48.7276,
                          48.7246,48.7323,
                          48.7211),
                  long = c(-122.4928,-122.4940,
                           -122.4942,-122.4939,
                           -122.4958,-122.4975,
                           -122.4946),
                  species = c("Apple", "Apple",
                              "Pear", "Plum",
                              "Fig", "Plum",
                              "Pear"),
                  status = c(rep("Confirmed",6), "Unconfirmed") )



ui <- fluidPage(
  
  titlePanel("Public Fruit Trees"),
  
  sidebarLayout(
    sidebarPanel(
      numericInput(inputId = "lat",
                   label = "Latitude DD",
                   value = 48.7211,step = 1e-3),
      numericInput(inputId = "long",
                   label = "Longitude DD",
                   value=-122.4942,step = 1e-3),
      selectInput(inputId = "species", label = "Species",
                  choices = c("Apple","Pear","Fig","Peach","Other")),
      actionButton(inputId = "addObservation",
                   label = "Add tree to database"),
      uiOutput("verifyObservation")
    ),
    mainPanel(
      tmapOutput(outputId = "tmapMap"),
      DT::dataTableOutput("updatedData"),
      verbatimTextOutput("y")
    )
  )
)

server <- function(input, output, session) {
  
  theData <- reactiveValues()
  theData$dat <- dat
  
  # 修改后的地图渲染逻辑
  output$tmapMap <- renderTmap({
    dat2plot <- theData$dat
    dat2plot <- st_as_sf(dat2plot, coords = c("long","lat"), crs=st_crs("EPSG:4326"))
    
    # 绘制基础地图
    map1 <- tm_shape(dat2plot) +
      tm_dots(col= "species", alpha=0.8,size = 0.1) +
      tm_legend(show = TRUE) +
      tm_view(set.zoom.limits = c(14,16))
    
    # 若有选中条目，叠加高亮图层
    if(length(selected()) == 1){
      map1 <- map1 + tm_shape(dat2plot[selected(),]) + 
        tm_dots(col = "red", alpha= 0.9, size=0.2, shape = 1) # 自定义高亮样式
    }
    
    map1 # 返回最终地图
  })
  
  # 添加新数据逻辑
  observeEvent(input$addObservation,{
    to_add <- data.frame(lat = input$lat,
                         long = input$long,
                         species = input$species,
                         status = "Unconfirmed"
    )
    theData$dat <- rbind(theData$dat,to_add)
  })
  
  output$updatedData <- DT::renderDataTable(
    theData$dat, selection = 'single'
  )
  
  selected <- reactive({input$updatedData_rows_selected})
  output$y = renderPrint(theData$dat[selected(), 4])
  
  # 地图点击更新坐标输入
  observeEvent(input$tmapMap_click, {
    updateNumericInput(
      inputId = "long",
      value = input$tmapMap_click$lng
    )
    
    updateNumericInput(
      inputId = "lat",
      value = input$tmapMap_click$lat
    )  
  }) 
      
  # 动态显示验证按钮
  output$verifyObservation <- renderUI({
    if(!is.null(selected()) && theData$dat[selected(), 4] == "Unconfirmed"){
      actionButton(inputId = "verifyObservation",
                   label = "Verify Tree Location ")
    }
  })
  
  observeEvent(input$verifyObservation,{
    theData$dat[selected(), 4] <- "Confirmed"
  })
}


shinyApp(ui = ui, server = server)

关键修改说明 #

1. 图层叠加逻辑：原代码中当有选中条目时，直接返回仅包含选中点的图层，现在改为将高亮图层通过+添加到基础地图map1上，实现叠加效果。
2. 高亮样式自定义：为高亮点设置了不同的颜色（红色）、形状（空心圆）、大小和透明度，确保与基础点区分明显。
3. 空值判断优化：在动态生成验证按钮时，增加了!is.null(selected())的判断，避免选中状态为空时出现错误。

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