在 Shiny Leaflet 中为空间子集绘制刷亮或访问绘制的形状几何图形

Question

我一直在关注 Leaflet/Shiny 中 addDrawToolbar 的新增功能，它允许自定义绘制形状等。

但我有兴趣通过访问绘制形状的几何形状来设置空间数据，这是如何完成的？ here 和 here 有一些努力，但无论如何我都无法让它们工作。

我认为plot brush 的巧妙功能可能适用于传单地图，但 Joe Cheng suggested last year 认为它没有到位。

那么，在这方面有什么发展或解决方法吗？或者有没有人设法使用 addDrawToolbar 访问绘制矩形的几何形状？

Answer 1

您可以使用 leaflet.extras 包中的 addDrawToolbar。

文档很少，但这个page 有Leaflet.draw 闪亮绑定的代码。您可以查找具有Shiny.onInputChange 的行，并在应用程序的服务器部分中，使用相应的input$event 来获取传递给Shiny.onInputChange 的数据。

这是一个小例子，您可以在城市周围绘制多边形，多边形中城市的名称将显示在地图下方：

rm(list=ls())
library(shiny)
library(leaflet)
library(leaflet.extras)

cities <- structure(list(AccentCity = c("Saint Petersburg", "Harare", "Qingdao", 
                                        "Addis Abeba", "Xian", "Anshan", "Rongcheng", "Kinshasa", "New York", 
                                        "Sydney", "Lubumbashi", "Douala", "Bayrut", "Luanda", "Ludhiana"
), Longitude = c(30.264167, 31.0447222, 120.371944, 38.749226, 
                 108.928611, 122.99, 116.364159, 15.3, -74.0063889, 151.205475, 
                 27.466667, 9.7, 35.5097222, 13.233174, 75.85), Latitude = c(59.894444, 
                                                                             -17.8177778, 36.098611, 9.024325, 34.258333, 41.123611, 23.528858, 
                                                                             -4.3, 40.7141667, -33.861481, -11.666667, 4.0502778, 33.8719444, 
                                                                             -8.836804, 30.9)), class = "data.frame", row.names = c(NA, -15L
                                                                             ), .Names = c("AccentCity", "Longitude", "Latitude"))



cities_coordinates <- SpatialPointsDataFrame(cities[,c("Longitude","Latitude")],cities)

ui <- fluidPage(
  leafletOutput("mymap"),
  textOutput("selected_cities")
)


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

  output$mymap <- renderLeaflet({
    leaflet() %>%
      setView(0,0,2) %>%
      addProviderTiles(providers$CartoDB.Positron) %>%
      addMarkers(data=cities,lat=~Latitude,lng=~Longitude,label=~AccentCity) %>%
      addDrawToolbar(
        targetGroup='draw',
        polylineOptions=FALSE,
        markerOptions = FALSE,
        circleOptions = TRUE)  %>%
      addLayersControl(overlayGroups = c('draw'), options =
                         layersControlOptions(collapsed=FALSE)) 
  })

  output$selected_cities <- renderText({
    #use the draw_stop event to detect when users finished drawing
    req(input$mymap_draw_stop)
    print(input$mymap_draw_new_feature)
    feature_type <- input$mymap_draw_new_feature$properties$feature_type

    if(feature_type %in% c("rectangle","polygon")) {

      #get the coordinates of the polygon
      polygon_coordinates <- input$mymap_draw_new_feature$geometry$coordinates[[1]]

      #transform them to an sp Polygon
      drawn_polygon <- Polygon(do.call(rbind,lapply(polygon_coordinates,function(x){c(x[[1]][1],x[[2]][1])})))

      #use over from the sp package to identify selected cities
      selected_cities <- cities_coordinates %over% SpatialPolygons(list(Polygons(list(drawn_polygon),"drawn_polygon")))

      #print the name of the cities
      cities[which(!is.na(selected_cities)),"AccentCity"]
    } else if(feature_type=="circle") {
      #get the coordinates of the center of the cirle
      center_coords <- matrix(c(input$mymap_draw_new_feature$geometry$coordinates[[1]],input$mymap_draw_new_feature$geometry$coordinates[[2]]),ncol=2)

      #calculate the distance of the cities to the center
      dist_to_center <- spDistsN1(cities_coordinates,center_coords,longlat=TRUE)

      #select the cities that are closer to the center than the radius of the circle
      cities[dist_to_center < input$mymap_draw_new_feature$properties$radius/1000,"AccentCity"]
    }


  })

}

shinyApp(ui, server)

编辑： 添加了对用户绘制圆圈的支持。

Answer 2

借鉴和调整上面 NicE 的答案（接受），这是我使用绘制的矩形对栅格进行子集和分区求和所做的。

至关重要的是，我不得不换掉 drawn_polygon <- Polygon(do.call(rbind,lapply(polygon_coordinates,function(x){**c(x[[2]][1],x[[1]][1]**)}))) 到 drawn_polygon <- Polygon(do.call(rbind,lapply(polygon_coordinates,function(x){**c(x[[1]][1],x[[2]][1]**)}))) 使提取工作，否则范围是错误的方式。

leaf.proj <- "+proj=merc +lon_0=0 +k=1 +x_0=0 +y_0=0 +a=6378137 +b=6378137 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
LL <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"

r <- raster("myraster.tif")

ui <- fluidPage(
  leafletOutput("mymap"),
  textOutput("selected_cities")
)


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

  output$mymap <- renderLeaflet({
    leaflet() %>%
      setView(0,0,4) %>%
      addProviderTiles(providers$CartoDB.Positron) %>%
      addRasterImage(r,project=FALSE, layerId="rasimg") %>%
      addDrawToolbar(
        targetGroup='draw',
        polylineOptions=FALSE,
        markerOptions = FALSE,
        circleOptions = FALSE,
        editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()))%>%
        addLayersControl(overlayGroups = c('draw'), options =
                         layersControlOptions(collapsed=FALSE)) 
  })

  output$rastersum <- renderText({
    #use the draw_stop event to detect when users finished drawing
    req(input$mymap_draw_stop)

    # get the coordinates of the polygon and make SpatialPolygons object
    polygon_coordinates <- input$mymap_draw_new_feature$geometry$coordinates[[1]]

    drawn_polygon <- Polygon(do.call(rbind,lapply(polygon_coordinates,function(x){c(x[[1]][1],x[[2]][1])})))
    sp <- SpatialPolygons(list(Polygons(list(drawn_polygon),"drawn_polygon")))

    # set coords as latlong then transform to leaflet projection
    proj4string(sp) <- LL
    polyre <- spTransform(sp, leaf.proj)

    e <- extract(r,polyre)
    sum(unlist(e),na.rm=T)

  })

}

runApp(shinyApp(ui, server), launch.browser = TRUE)

我包含editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()) 以允许我删除绘制的多边形，但理想情况下我希望它在我绘制一个新多边形时自动删除，我将在某个时候构建它。