r - 如何在shinyapp传单 map 中使用clusterOptions？

Question

以下代码适用于常见标记。
聚类标记代码在 Shiny 之外工作正常。
我怎样才能让它在 Shiny 的工作。

library(leaflet)
library(shiny)

# TRUE, working simple version
simple <- TRUE # change to FALSE FOR non-working desired version

col_feed_con_raw_01_coords <- data.frame(lng = rep(sample(seq(from=-101, to=-99,by=.4), 100, replace = T),3),
                                         lat = rep(sample(seq(from=39, to=41,  by=.4), 100, replace=T),3),
                                         service_type = sample(LETTERS[1:4], 300, replace = T)
)

ser_types <- unique(col_feed_con_raw_01_coords$service_type)
ser_types <- sort(ser_types)

colorList4  <- c('forestgreen',
                 '#ee0000',
                 'orange',
                 'cornflowerblue'
)


ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
  leafletOutput("map", width = "100%", height = "100%"),
  absolutePanel(top = 10, right = 10,
                checkboxGroupInput("service_type",
                                   "Choose service:"
                                   ,choiceNames  = ser_types
                                   ,choiceValues = 1:4
                                   ,selected = 1:4
                )
                ,checkboxInput("allnone",
                               "All/None"
                               ,value=TRUE)
  )
)

server <- function(input, output, session) {
  
  print(paste0("Running in: ",
               isolate(session$clientData$url_hostname),":"
               ,isolate(session$clientData$url_port))
  )
  
  observeEvent(input$allnone,{
    
    if(input$allnone){
      updateCheckboxGroupInput(session,"service_type",selected = 1:4)
    } else {
      updateCheckboxGroupInput(session,"service_type"
                               ,choiceNames=ser_types
                               ,choiceValues = 1:4
                               ,selected = NULL)
    }
  })
  
  filteredColors <- reactive({
    colorList4[as.numeric(input$service_type) ]
  })
  
  filteredService <- reactive({
    ser_types[as.numeric(input$service_type) ]
  })
  
  filteredData <- reactive({
    col_feed_con_raw_01_coords[which(col_feed_con_raw_01_coords$service_type %in%
                                       filteredService() ), ]
  })
  
  mycolors <- reactive({
    colorFactor(palette = filteredColors()
                ,filteredService()
    )
  })
  
  output$map <- renderLeaflet({
    
    leaflet(data = filteredData()
            ,options = leafletOptions(preferCanvas = TRUE) )  %>%
      addTiles(options = providerTileOptions(
        updateWhenZooming = FALSE,
        updateWhenIdle = FALSE) ) %>% setView(lng = -100 #4.65
                                              ,lat = 40  #-74.1
                                              ,zoom = 9)
    
  })
  
  observe({
    if(length(input$service_type) > 0 ) {
      
      pal <- mycolors()
      
      if(simple){
        leafletProxy("map",data = filteredData()) %>% addTiles() %>%
          addCircleMarkers(~lng, ~lat,
                           radius = ~ 10
                           , fillColor = ~pal(service_type)
                           , stroke = FALSE
                           , fillOpacity = 0.7
          )
      }
      if(!simple){
        leafletProxy("map",data = filteredData()
        )  %>% addTiles(
          options = providerTileOptions(
            updateWhenZooming = FALSE,      # map won't update tiles until zoom is done
            updateWhenIdle = FALSE)
        ) %>%
          addCircleMarkers(data = filteredData()
                           ,~lng
                           ,~lat
                           ,clusterOptions = markerClusterOptions(
                             iconCreateFunction=JS("function (cluster) {
                          var childCount = cluster.getChildCount();
                          if (childCount < 100) {
                            c = 'rgba(255, 150, 150, 0.5);'
                          } else if (childCount < 500) {
                            c = 'rgba(255, 100, 100, 0.5);'
                          } else {
                            c = 'rgba(255, 50, 50, 0.5);'
                          }
                          return new L.DivIcon({ html: '<div style=\"background-color:'+c+'\"><span>' + childCount + '</span></div>',
                          className: 'marker-cluster'

                          });
                        }"
                             )
                             ,spiderfyOnMaxZoom = TRUE
                           )
                           , fillColor   = ~pal(service_type)
                           , stroke      = FALSE
                           , fillOpacity = 0.7
          ) # aCM
      }
    }
  })
  
  observe({
    
    if(length(input$service_type)>0){
      
      proxy <- leafletProxy("map",data = filteredData() )
      
      pal<-mycolors()
      proxy %>% clearControls()
      proxy %>% addLegend('bottomright',
                          pal = pal,
                          values = ~service_type,
                          title = 'Services:',
                          opacity = 1)
      
    }
  })
}

shinyApp(ui, server)

Answer 1

目前看来这并不容易，因为 leafetProxy无法在其参数中与 JS 一起正常工作。有一个pull request对于启用此行为的传单 R 包，但尚未合并。显然它计划用于 2.1 版。
公关说:

htmlwidgets provides built-in support for the JS function, which lets you mark widget data string values in R to be evaluated as JS code when the widget data is deserialized in the browser. This isn't supported natively in Shiny though, so leafletProxy did not automatically inherit this behavior. The changes in this PR reimplement that mechanism for leafletProxy.

因此，目前似乎不支持它。
在公关 this SO post已连接。那里接受的答案声称有一种解决方法，但它是从 2017 年开始的，我无法再让它工作了。