r - 使用 R 中的 addDrawToolbar 在传单 map 上绘制额外标记

Question

我在传单 map 上添加了一个工具栏，以便非编码人员可以轻松绘制标记。为此，我使用了以下 R 包:leaflet、leaflet.extras 和shiny。

我有几个问题:

1)我添加了markerOptions(见下文)来定义红叶的图标。根据我的经验，你只能有一种选择。我的意思是，没有办法让非编码人员从您以与我相同的方式定义的几个图标中进行选择。是否有可能以其他方式实现这一点？

2)一旦您单击左下角的“样式编辑器”来编辑叶子图标(见下文)，它就会切换回其固有的图标池，并且您要编辑的叶子图标将变成此中的第一个图标水池。

实际上，如果有一种方法可以将额外的图标添加到这个池中(如下右图所示)，那么我的第一个问题就得到了解决。该解决方案并不严格需要在 R 中。

library(shiny)
library(leaflet)
library(leaflet.extras)


ui = fluidPage(
   tags$style(type = "text/css", "#map {height: calc(100vh - 20px)!important;}"),
   leafletOutput("map")
)

server = function(input,output,session){
   output$map = renderLeaflet(
   leaflet()%>%

   addTiles(urlTemplate = "http://mt0.google.com/vt/lyrs=m&hl=en&x={x}&y={y}&z={z}&s=Ga")%>%

   addMeasure(
    primaryLengthUnit = "kilometers",
    secondaryAreaUnit = FALSE
    )%>%

   addDrawToolbar(
    targetGroup='draw',
    editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()),

    markerOptions = filterNULL(list(markerIcon = makeIcon(iconUrl = "http://leafletjs.com/examples/custom-icons/leaf-red.png")))) %>%
  setView(lat = 45, lng = 9, zoom = 3) %>% 

  addStyleEditor(position = "bottomleft", 
                 openOnLeafletDraw = TRUE)
  )
}

shinyApp(ui,server)

Answer 1

您可以通过以下方式在选择的 HTML 标记中列出一堆可能的图标(这里我选择 font-awesome):

1) 获取精美字体图标的完整列表

fa_list <- read_html("http://astronautweb.co/snippet/font-awesome/") %>% 
  html_nodes("span.icon-name") %>% 
  html_text()
fa_pretty <- gsub("^fa-", "", fa_list)

2) 在您的 ui 中，加载 font-awesome 字体

tags$head(
  tags$link(rel = "stylesheet", href = "https://maxcdn.bootstrapcdn.com/font-awesome/4.6.1/css/font-awesome.min.css")
)

3) 制作一个可以显示图标选择的 UI 小部件

shinyWidgets::pickerInput("defaultIcon", "Default Marker", choices = fa_pretty, 
                          options = pickerOptions(liveSearch = TRUE),
                          choicesOpt = list(icon = paste("fa", fa_list), 
                                            iconBase = "fontawesome"))

用户可以选择他/她想要的图标，并且您的工具栏可以通过编写以下内容来尊重它:

... %>% 
  addDrawToolbar(...,
    markerOptions = list(markerIcon = makeAwesomeIcon(icon = input$defaultIcon, library = "fa"))

但是，addDrawToolbar 似乎与 leafletProxy 配合得不太好，因此，如果您更改 UI 中的标记图标，它会删除​​传单 map 并你必须从头开始。相反，如果您想切换图标并保留现有标记，您可以定义自己的功能来添加标记。在我看来，这是一个更灵活的解决方案，仍然可以处理您的所有 UI 和功能请求。完整示例如下:

library(shiny)
library(leaflet)
library(leaflet.extras)
library(rvest)

fa_list <- read_html("http://astronautweb.co/snippet/font-awesome/") %>% 
  html_nodes("span.icon-name") %>% 
  html_text()
fa_pretty <- gsub("^fa-", "", fa_list)
# Awesome-icon markers only support the colors below...
fa_cols <- c("red", "darkred", "lightred", "orange", "beige", "green", "darkgreen", 
             "lightgreen", "blue", "darkblue", "lightblue", "purple", "darkpurple", 
             "pink", "cadetblue", "white", "gray", "lightgray", "black")

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet",
      href = "https://maxcdn.bootstrapcdn.com/font-awesome/4.6.1/css/font-awesome.min.css")
  ),
  tags$style(type = "text/css", "#map {height: calc(100vh - 20px)!important;}"),
  fluidRow(
    splitLayout(cellArgs = list(style = "overflow: visible;"),
      shinyWidgets::pickerInput("defaultIcon", "Default Marker", choices = fa_pretty, 
                                options = shinyWidgets::pickerOptions(liveSearch = TRUE),
                                choicesOpt = list(icon = paste("fa", fa_list), 
                                                  iconBase = "fontawesome")),
      colourpicker::colourInput("defaultColor", "Default icon color"),
      colourpicker::colourInput("defaultBg", "Default marker color", palette = "limited", 
                                allowedCols = fa_cols, returnName = TRUE, value = "red")
    ),
    tags$div( tags$b("Place Marker"), 
              shinyWidgets::switchInput("edit_mode", "Edit Mode", 
                                        onLabel = "Click on the map to add a marker"))
  ),
  leafletOutput("map")
)

server <- function(input,output,session){
  react_list <- reactiveValues()
  # While the user has toggled the edit-mode input, register any future map-clicks
  # as reactive values.
  observe({
    if (input$edit_mode & !isTRUE(input$map_click$.nonce == react_list$nonce)) {
      react_list$mapEditClick <- input$map_click
    }
    react_list$nonce <- input$map_click$.nonce
  })

  output$map <- renderLeaflet(
    leaflet() %>%
      addProviderTiles(providers$CartoDB.Positron) %>% 
      addMeasure(
        primaryLengthUnit = "kilometers",
        secondaryAreaUnit = FALSE) %>%
      setView(lat = 45, lng = 9, zoom = 3)
  )
  # When a user clicks on the map while being in edit-mode, place a marker with
  # the chosen icon, color and marker-color at the click coordinates.
  observeEvent(react_list$mapEditClick, {
    leafletProxy("map") %>% 
      addAwesomeMarkers(
        lng     = react_list$mapEditClick$lng, 
        lat     = react_list$mapEditClick$lat,
        layerId = as.character(react_list$mapEditClick$.nonce),
        icon    = makeAwesomeIcon(icon     = input$defaultIcon, 
                               library     = "fa", 
                               iconColor   = input$defaultColor, 
                               markerColor = input$defaultBg),
        label = "Click to delete", 
        labelOptions = labelOptions(TRUE))
  })
  # Delete the marker when it has been clicked.
  observeEvent(input$map_marker_click, {
    leafletProxy("map") %>%
      removeMarker(as.character(input$map_marker_click$id))
  })
}

shinyApp(ui,server)