我正在开发一个带有“Main”面板和“Map”面板的Shiny应用。我希望应用启动时停留在主面板，然后当用户点击某些按钮或链接时，跳转到包含可交互Leaflet地图的地图面板，在地图中会根据点击的是哪个按钮来高亮一个给定的多边形。

我的代码基本上已经跑起来，唯一的问题是第一次点击按钮时，地图面板会按预期切换过去，但没有高亮任何多边形。如果我返回主面板再选另一个按钮，那么就正常工作。如果在点击任意按钮之前，先手动切换到地图面板，然后再切换回主面板，也会正常工作。这就像地图需要第一次加载并显示之后，才能进行多边形高亮。可能是我对执行调度还没完全理解。

以下是我的问题的一个可复现的简化示例：

require(shiny)
require(bslib)
require(leaflet)
require(sf)

lat <- runif(1,-90,90)
lon <- runif(1,-180,180)

point1 <- st_point(c(lon+runif(1,-15,15),lat+runif(1,-2,2)))
point2 <- st_point(c(lon+runif(1,-15,15),lat+runif(1,-2,2)))
point3 <- st_point(c(lon+runif(1,-15,15),lat+runif(1,-2,2)))

places_sf <- st_sf(
  place_id = c("point1", "point2","point3"),
  place_name = c("Place 1", "Place 2","Place 3"),
  geometry = st_sfc(point1, point2,point3),
  crs = 4326
)

ui <- page_navbar(id="navBar",
                  nav_panel("Main",radioButtons("placeSelector","Select a place",choices=list("Place 1"="point1","Place 2"="point2","Place 3"="point3"))),
                  nav_panel("Map",leafletOutput("Map", width="100%", height="600px"))
)

server <- function(input, output,session) {

  launch <- reactiveVal(1)

  output$Map <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Esri.OceanBasemap") %>%
      setView(lon,lat,5) %>%
      addScaleBar(position="bottomright") %>%      addCircles(data=places_sf,label=places_sf$place_name,color="green",radius=50000)
  })

  observeEvent(input$placeSelector, {

    if(!launch()){
      updateNavbarPage(
        inputId = "navBar",
        selected = "Map"
      )

      place <- places_sf[which(places_sf$place_id==input$placeSelector),]

      leafletProxy("Map") %>%
        clearGroup("highlight") %>%
        addCircles(
          data = place,
          group = "highlight",
          color = "red",
          fillColor = "yellow",
          radius=50000,
          fillOpacity = 0.7,
          label = ~ place_name
        )

    }
    launch(0)
  })

}

shinyApp(ui = ui, server = server)

如何在地图首次渲染时就高亮多边形？

解决方案

考虑到你希望 observeEvent() 切换到地图标签页，启动时最好不选中任何单选按钮。换句话说，如果你希望预先选中一个预定义的单选按钮，那么让地图标签页处于打开状态会更合理。

为此，下面给出一个解决方案：

• 以初始状态不选中任何单选按钮
• 将“place”选择定义为一个 reactive()
• 使用两个 observeEvent()：一个用于在标签/面板之间切换，另一个用于监听“navBar”的变化

library(shiny)
library(bslib)
library(leaflet)
library(sf)

set.seed(42) # For reproducibility

lat <- runif(1, -90, 90)
lon <- runif(1, -180, 180)

point1 <- st_point(c(lon + runif(1, -15, 15), lat + runif(1, -2, 2)))
point2 <- st_point(c(lon + runif(1, -15, 15), lat + runif(1, -2, 2)))
point3 <- st_point(c(lon + runif(1, -15, 15), lat + runif(1, -2, 2)))

places_sf <- st_sf(
  place_id = c("point1", "point2", "point3"),
  place_name = c("Place 1", "Place 2", "Place 3"),
  geometry = st_sfc(point1, point2, point3),
  crs = 4326
  )

ui <- page_navbar(
  id = "navBar",
  nav_panel(
    "Main",
    radioButtons(
      "placeSelector", "Select a place",
      choices = list("Place 1" = "point1",
                     "Place 2" = "point2",
                     "Place 3" = "point3"),
      # Start with no selected radio button
      selected = character(0))
    ),
  nav_panel("Map", leafletOutput("Map", width = "100%", height = "600px"))
  )

server <- function(input, output, session) {

  # Set place as reactive()
  place <- reactive({
    req(input$placeSelector)
    places_sf[which(places_sf$place_id == input$placeSelector), ]
  })

  # Switch tabs/panels
  observeEvent(input$placeSelector, {
    updateNavbarPage(
      inputId = "navBar",
      selected = "Map"
    )
  })

  # Update Map
  observeEvent({input$navBar}, {

    # Check if radio button selected
    req(input$placeSelector) 

    if (input$navBar == "Map") {
      leafletProxy("Map") %>%
        clearGroup("highlight") %>%
        addCircles(
          data = place(),
          group = "highlight",
          color = "red",
          fillColor = "yellow",
          radius = 50000,
          fillOpacity = 0.7,
          label = ~ place_name
        )
    }
  },
  ignoreInit = TRUE)

  output$Map <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Esri.OceanBasemap") %>%
      setView(lon, lat, 5) %>%
      addScaleBar(position = "bottomright") %>%  
      addCircles(
        data = places_sf,
        label = ~ place_name,
        color = "green",
        radius = 50000
      )
  })

}

shinyApp(ui = ui, server = server)