r - Drawing extra markers on a leaflet map with addDrawToolbar in R

Question

I have added a Toolbar on a leaflet map to make it easy for non-coders to draw markers. For this purpose, I make use of the following R packages: leaflet, leaflet.extras, and shiny.

I have a couple of questions:

1) I have added markerOptions (see below) to define an icon of the red leaf. As far as I experienced, you can only have one option. I mean there is no way to let a non-coder to choose from a couple of icons you define in the same way as I did. Is it possible to make it happen in some other way?

2) Once you have clicked STYLE EDITOR on the bottom left to edit the leaf icon (see below), it switches back to the icons pool it has intrinsically and the leaf icon you mean to edit turn into the first icon in this pool.

Actually, if there is a way to add extras icons into this pool seen below on the right, then my first question gets solved. The solution does not strictly need to be in 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)

标签： rshinyleaflet

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，加载字体真棒字体

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 中的标记图标，它将擦除传单地图，您必须重新开始。相反，如果您想切换图标并保留现有标记，您可以定义自己的功能来添加标记。在我看来，这是一个更灵活的解决方案，仍然可以处理您的所有 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)