Shiny集成Leaflet渲染HTML标签时地图固定卡顿问题

• 基于Shiny + Leaflet开发支持用户选择筛选条件动态更新的地图应用时，完成点位标签配置后，点击操作按钮刷新地图出现明显性能问题，固定加载耗时约10秒
• 排查确认：耗时与待渲染点位数量完全无关，渲染1个点位和3000个点位耗时均稳定在10秒
• 对照测试结果：移除标签配置中的HTML()函数、改用无格式纯文本标签后，任意点位数量下刷新操作都可以瞬间完成渲染
• 核心疑问：HTML格式标签渲染耗时远高于纯文本标签、且耗时不受点位数量影响的根本原因

global.R #

# 加载依赖包
library(shiny)
library(sf)
library(leaflet)
library(maps)
library(dplyr)
library(htmltools)

# 初始化数据
print('Read in Data')
df <- read.delim("inst/Sample Data.csv", na.strings="")%>%
  mutate(SurfaceHoleLongitude=as.numeric(substr(SurfaceHoleLongitude,2,length(SurfaceHoleLongitude))))%>%
  filter(is.na(SurfaceHoleLongitude)==FALSE & is.na(SurfaceHoleLatitude)==FALSE)%>%
  filter(SurfaceHoleLongitude!='NA' & SurfaceHoleLatitude!='NA')%>%
  as.data.frame()
print('Create Labels')
df <- df %>%
  mutate(pointlabel=paste0(`Lease.Name`,
                          "<br>", County,", ",State,
                          "<br> Operator: ", Operator,
                          "<br> Customer Name: ", Customer.Name,
                          "<br> Reservoir: ", Reservoir
  ))%>%
  rowwise()%>%
  mutate(pointlabel=HTML(pointlabel))
print('Finished Making Labels')

app.R #

# 可隐藏筛选器的标签页集合
parameter_tabs <- tabsetPanel(
  id = "filterTabset",
  type = "hidden",
  tabPanel("Operator",
           selectInput(
             selected = 'BCE Mach III LLC',
             inputId='Filter1', multiple = TRUE, label='Operator',
             choices=df%>%select(Operator)%>%unique()%>%pull())),
  tabPanel("Customer Name", 
           selectInput(
             inputId='Filter2', multiple = TRUE, label='Customer Name',
             choices=df%>%select(Customer.Name)%>%unique()%>%pull())),
  tabPanel("Region", 
           selectInput(
             inputId='Filter3', multiple = TRUE, label='Region',
             choices=df%>%select(Region)%>%unique()%>%pull())),
  tabPanel("County", 
           selectInput(
             inputId='Filter4', multiple = TRUE, label='County',
             choices=df%>%select(County)%>%unique()%>%pull())),
  tabPanel("State", 
           selectInput(
             inputId='Filter5', multiple = TRUE, label='State',
             choices=df%>%select(State)%>%unique()%>%pull())),
  tabPanel("Reservoir", 
           selectInput(
             inputId='Filter6', multiple = TRUE, label='Reservoir',
             choices=df%>%select(Reservoir)%>%unique()%>%pull()))
)

# 定义UI
ui <- fluidPage(
  titlePanel("Engineering Toolkit"),
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId='FilterFieldSelection',
        label='Filter Field',
        choices=c('Operator','Customer Name','Region','County','State','Reservoir'),
        selected = 'Operator',
        multiple = FALSE
      ),
      parameter_tabs,
      actionButton('button','Load Map')
    ),
    mainPanel(
      leafletOutput("WellMap")
    )
  )
)


# 定义服务端逻辑
server <- function(input, output) {
  
  # 响应式：根据用户选择筛选数据
  filteredData <- reactive({
    df%>%
      filter(case_when(length(input$Filter1)>0 ~ Operator      %in% input$Filter1,TRUE~1==1))%>%
      filter(case_when(length(input$Filter2)>0 ~ Customer.Name %in% input$Filter2,TRUE~1==1))%>%
      filter(case_when(length(input$Filter3)>0 ~ Region        %in% input$Filter3,TRUE~1==1))%>%
      filter(case_when(length(input$Filter4)>0 ~ County        %in% input$Filter4,TRUE~1==1))%>%
      filter(case_when(length(input$Filter5)>0 ~ State         %in% input$Filter5,TRUE~1==1))%>%
      filter(case_when(length(input$Filter6)>0 ~ Reservoir     %in% input$Filter6,TRUE~1==1))
    
  })
  
  # 切换筛选字段时显示对应筛选器
  observeEvent(input$FilterFieldSelection, {
    updateTabsetPanel(inputId = "filterTabset", selected = input$FilterFieldSelection)
  })
  
  # 初始地图渲染
  output$WellMap <- renderLeaflet({
      counties.sf <- st_as_sf(map("county", plot = FALSE, fill = TRUE))
      counties.latlong<-st_transform(counties.sf,crs = "+init=epsg:4326")
      
      leaflet() %>% 
        addTiles() %>%
        addPolygons(weight=1,fill=FALSE,color='black',data=counties.latlong) %>%
        addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,label= ~pointlabel,
          group = 'pointLayer',data=df%>%filter(Operator=='BCE Mach III LLC'),
          radius=0.5,color='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
    }) 
  
  # 点击按钮时更新地图点位
  observeEvent(input$button,{
    leafletProxy("WellMap", data = filteredData())%>%
      clearGroup('pointLayer')%>%
      addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,
                 group = 'pointLayer',radius=0.5,label= ~pointlabel,
                 color ='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
  })
}

# 启动应用
shinyApp(ui = ui, server = server)

固定10秒耗时的核心原因是标签预处理方式触发了htmltools包的全量依赖解析逻辑，和当前渲染的点位数量无关：

1. 全局预处理阶段用rowwise() + HTML()给全量数据集所有点位逐行生成了独立的html类对象，这类对象不是普通字符串，会附带完整的HTML依赖标记、DOM结构属性
2. Leaflet在处理公式格式传入的label参数（即~pointlabel写法）时，只要检测到列中存在html类对象，就会触发全量HTML依赖扫描、去重、序列化校验流程：这个流程遍历的是全局环境中全量数据集的所有HTML标签对象，不是当前筛选后要渲染的子集，因此不管筛选后剩1个还是3000个点位，扫描的总数据量固定，耗时也就稳定在10秒
3. 纯文本标签不需要走HTML依赖解析、DOM结构校验的流程，会直接作为普通字符串序列化成JSON传给前端，因此没有额外开销，渲染速度极快。

• 全局预处理阶段移除标签上的HTML()包裹，pointlabel列保留普通字符串格式；同时删除不必要的rowwise()调用，paste0为矢量化函数，逐行mutate本身就会产生额外性能开销
• 在addCircles的label参数中，仅对当前筛选后待渲染的点位做HTML解析，参数写法改为label = ~lapply(pointlabel, HTML)。此时HTML解析范围仅覆盖当前需要渲染的点位，耗时会与点位数量正相关，不会出现固定时长的卡顿。

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