如何将R Shiny选择框置于顶层？解决Leaflet图例遮挡问题

问题描述 #

在我的Shiny应用里，Leaflet地图会根据指标选择动态变化，但下拉选择框被Leaflet图例挡住了，没法正常选择指标。想问问怎么通过设置层级（针对Shiny的select input或者Leaflet图例）把下拉框放到前端显示？

用户代码 #

output$geo_metric_type <- renderUI({ 
  selectInput(inputId = 'geo_metric_type',
              label="", 
              choices=c('Targeted Change','Reg. Rate Change', 'Act. Rate Change', 'Inf. Rev/Act Change'), 
              selected="Targeted Change") 
}) 

# Leaflet Object 
mycolpal <- function(x){ 
  if(min(x) > 0 && max(x) > 0){ 
    x <- x*10 
    min = abs(round(min(x))) 
    max = abs(round(max(x))) 
    rc2 = colorRampPalette(colors = c("white", "green"), space="Lab")(max-min) 
    rampcols <- rc2 
    rampcols 
  } else if (min(x) < 0 && max(x) < 0){ 
    x <- x*10 
    min = abs(round(min(x))) 
    max = abs(round(max(x))) 
    rc1 = colorRampPalette(colors = c("red", "white"), space="Lab")(min-max) 
    rampcols <- rc1 
    rampcols 
  } else{ 
    x <- x*10 
    min = abs(round(min(x))) 
    max = abs(round(max(x))) 
    rc1 = colorRampPalette(colors = c("red", "white"), space="Lab")(min) 
    rc2 = colorRampPalette(colors = c("white", "green"), space="Lab")(max) 
    rampcols = c(rc1, rc2) 
    rampcols 
  } 
} 

color = "#666" 
weight = 0.5 
opacity = 1 
fillOpacity = 1 
dashArray = "" 
hl_color = "black" 
hl_weight = 1 
hl_dashArray = "" 

pal <- colorNumeric( 
  palette = mycolpal(regions1()@data$change_targeted), 
  domain = regions1()@data$change_targeted) 

legendpal <- colorNumeric( 
  palette = rev(mycolpal(regions1()@data$change_targeted)), 
  domain = regions1()@data$change_targeted) 

leaflet(regions1(), options = leafletOptions(zoomControl = FALSE, attributionControl=FALSE)) %>% 
  addPolygons(color = color, weight = weight, 
              opacity = opacity, fillOpacity = fillOpacity, 
              dashArray = dashArray, 
              fillColor = ~pal(change_targeted), 
              highlightOptions = highlightOptions(color = hl_color, weight = hl_weight, 
                                                 dashArray = hl_dashArray, bringToFront = TRUE), 
              label = ~as.character(paste0(region," : ",round(change_targeted,1),"%")), 
              labelOptions = labelOptions(noHide = T, textOnly = F, direction = "left", textsize = "12px")) %>% 
  setView(35, 40, 0.4) %>% 
  addLegend("bottomright", pal = legendpal, values = ~change_targeted, 
            title = NULL, 
            labFormat = labelFormat(suffix = "%",transform = function(x) sort(x, decreasing = T)) , 
            opacity=1) 

解决方案 #

这个问题本质就是HTML元素的层级冲突——Leaflet图例的默认层级比Shiny的下拉选择框高，所以会把下拉框盖住。给你几个实用的解决办法：

方法1：给下拉框提升层级 #

直接给你的selectInput套一个带自定义样式的div，设置更高的z-index值，让它显示在图例上方。修改renderUI部分的代码就行：

output$geo_metric_type <- renderUI({ 
  tags$div(
    style = "z-index: 1000; position: relative;",  # z-index要足够大，position是样式生效的前提
    selectInput(inputId = 'geo_metric_type',
                label="", 
                choices=c('Targeted Change','Reg. Rate Change', 'Act. Rate Change', 'Inf. Rev/Act Change'), 
                selected="Targeted Change") 
  )
}) 

Leaflet图例的默认层级一般在400左右，设1000完全够用。

方法2：降低图例的层级 #

如果你不想动下拉框，也可以给Leaflet图例降层级。在Shiny的UI部分加一段自定义CSS：

tags$head(
  tags$style(HTML("
    .leaflet-control {
      z-index: 999 !important;  /* 只要比下拉框的默认层级低就行 */
    }
  "))
)

或者更精准一点，给图例加个自定义类再设置样式：
先修改addLegend的代码：

addLegend("bottomright", pal = legendpal, values = ~change_targeted, 
          title = NULL, 
          labFormat = labelFormat(suffix = "%",transform = function(x) sort(x, decreasing = T)) , 
          opacity=1,
          className = "custom-map-legend")  # 添加自定义类名

然后在UI里加CSS：

tags$head(
  tags$style(HTML("
    .custom-map-legend {
      z-index: 999 !important;
    }
  "))
)

方法3：换个图例位置 #

最简单的办法——把图例挪到不遮挡下拉框的地方，比如bottomleft、topleft或者topright，改addLegend的第一个参数就行：

addLegend("bottomleft", pal = legendpal, values = ~change_targeted, ...)

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