R在传单地图中绘制匹配选定多边形 [英] R Plot matching selected polygon in leaflet map
问题描述
我建立了一张传单地图，我想绘制我点击的多边形.我尝试使用input$mymap_shape_click"和event$id"，但它不起作用.请你帮助我好吗 ?这是一个可重现的例子.
I built a leaflet map and I would like to plot the polygon I have clicked on. I tried to use "input$mymap_shape_click" and "event$id" but it does not work. Could you please help me ? This is a reproducible example.
这是我的用户界面:
library(shiny)
library(shinydashboard)
library(leaflet)
library(plotly)
library(shinyBS)
ui <- dashboardPage(
dashboardHeader(
title = "TEST",
titleWidth = 500), # end of dashboardHeader
dashboardSidebar(## Sidebar content
sidebarMenu(
id = "Menu1",
menuItem("Map", tabName = "map", icon = icon("globe"))
) # end of sidebarMenu
), # end of dashboardSidebar
# Body content
dashboardBody(
tabItem(tabName = "map",
bsModal("modal", "Map datas", "btn_modal", size = "large",
fluidRow(
column(12, dataTableOutput("map_table"))
) # end of fluidRow(
), # end of bsModal(
fluidRow(
div(class="outer",
tags$head(includeCSS("D:/R/TEST_RP_2014/www/styles.css")),
# Map
leafletOutput("mymap",width="100%",height="945px"),
# Controls
absolutePanel(id = "controls",
class = "panel panel-default",
fixed = TRUE,
draggable = FALSE,
top = "auto",
left = "auto",
right = 10,
bottom = 200,
width = 440,
height = 500,
h2("TEST"),
plotlyOutput("graphe_df", height = 300),
br(),
fluidRow(
column(3,actionButton("reset_button",
"",
width = 80,
icon = icon("home"),
style = "color : #FFF ; background-color : #333333 ; border-color : #FFF")),
column(3,actionButton("btn_modal",
"",
width = 80,
icon("table"), icon("globe"),
class = "btn_block",
style = "color : #FFF ; background-color : #333333 ; border-color : #FFF")),
column(3,downloadButton("downloadData_map",
"Export",
class = "butt"),
tags$head(tags$style(".butt{background-color : #333333;}
.butt{border-color: #FFF;}
.butt{color: #FFF;}"))),
column(3,actionButton("export_map",
"",
width = 80,
icon("arrow-down"), icon("globe"),
style = "color : #FFF ; background-color : #333333 ; border-color : #FFF"))
) # end of fluidRow(
) # end of absolutePanel
) # end of div(class="outer",
) # end of fluidRow
) # end of tabItem
) # end of dashboardBody
) # end of dashboardPage
还有我的服务器:
shinyServer(function(input, output, session) {
################################## OUTPUT BASE MAP #######################################
output$mymap <- renderLeaflet({
leaflet() %>%
setView(lng = 166, lat = -21, zoom = 8) %>%
# Basemap
addProviderTiles("Esri.WorldImagery",
group = "Esri World Imagery")
}) # end of renderLeaflet
# Joint shapefile and table T_1_1
shape_new_table <- append_data(Shape_Com_simples, T_1_2, key.shp = "CODE_COM", key.data="PC")
# Joint hapefile and Centroide
shape_new_table2 <- append_data(shape_new_table, Centroides, key.shp = "CODE_COM", key.data="PC")
# Checking joint
str(shape_new_table2@data)
# Col Pal
Palette_col <- colorBin(palette = c("#FFF4BF", "#E3CB7D", "#DBA54F", "#B37A00", "#8C6000"),
bins = c(28, 30, 32, 34, 36, 38),
domain=shape_new_table2@data$P_20,
n = 5)
# Tooltips
infob <- paste0("<span style='color: #B37A00; font-size: 10pt'><strong>Commune : </strong></span>",
shape_new_table2@data$Commune,
br(),
"<span style='color: #B37A00; font-size: 10pt'><strong>Population : </strong></span>",
shape_new_table2@data$Population,
br(), br(),
"<span style='color: #B37A00; font-size: 10pt'><strong>moins de 20 ans : </strong></span>",
shape_new_table2@data$M_20, " - ", shape_new_table2@data$P_20, " %",
br(),
"<span style='color: #B37A00; font-size: 10pt'><strong>20 - 39 ans : </strong></span>",
shape_new_table2@data$T_20_39, " - ", shape_new_table2@data$P_20_39, " %",
br(),
"<span style='color: #B37A00; font-size: 10pt'><strong>40 - 59 ans : </strong></span>",
shape_new_table2@data$T_40_59, " - ", shape_new_table2@data$P_40_59, " %",
br(),
"<span style='color: #B37A00; font-size: 10pt'><strong>60 ans et plus : </strong></span>",
shape_new_table2@data$T_60, " - ", shape_new_table2@data$P_60, " %",
br())
################################### MAP UPDATE #######################################
leafletProxy("mymap") %>%
# Displaying COMMUNE choropleth layer
addPolygons(data = shape_new_table2,
stroke=TRUE,
weight = 0.5,
fillOpacity = 1,
color = "#666666",
opacity = 1,
fillColor= ~Palette_col(shape_new_table2@data$P_20),
popup=infob,
group = "Rate") %>%
# Proportional symbols
addCircles(data = shape_new_table2,
lng = ~POINT_X,
lat = ~POINT_Y,
stroke = TRUE,
weight = 0.5,
color = "#C71F1F",
fillOpacity = 0.6,
radius = ~sqrt(shape_new_table2@data$M_20) * 150,
popup=infob,
group = "Number") %>%
# Displaying COMMUNE LIMITS layer
addPolygons(data = shape_new_table2,
stroke=TRUE,
weight = 0.5,
color = "#666666",
opacity = 1,
fillOpacity = 0,
popup=infob,
group = "Cities limits") %>%
# Layers controls
addLayersControl(baseGroups = c("Esri World Imagery","OpenStreetMap.Mapnik","Stamen Watercolor"),
overlayGroups = c("Rate", "Number", "Cities limits"),
position = "bottomleft",
options = layersControlOptions(collapsed = TRUE)) %>%
# Legend
addLegend(position = "bottomright",
title = paste("Sur 100 personnes en 2014", br(), "combien ont moins de 20 ans"),
opacity = 1,
colors = c("#FFF4BF", "#E3CB7D", "#DBA54F", "#B37A00", "#8C6000"),
labels = c("28 - 29%","30 - 31%", "32 - 33%", "34 - 35%", "36 - 38%"))
# Back to initial zoom
observe({
input$reset_button
leafletProxy("mymap") %>% setView(lng = 166, lat = -21, zoom = 8)
})
# Access to map datas
observe({
input$btn_modal
output$map_table <- renderDataTable({get(paste0("T_","1_2"))}, options = list(lengthMenu = c(10, 20, 33), pageLength = 20))
})
# Mouse event
observeEvent(input$mymap_shape_click, {
event <- input$mymap_shape_click
if(is.null(event))
return()
if(!is.null(event)) {
leafletProxy("mymap") %>%
setView(lng = event$lng, lat = event$lat, zoom = 11)
# Create pie chart
tmp <- T_1_2
Graphe_dfFL3 <- data.frame(
Ages = c("less than 20 yrs old",
"20 - 39 yrs old",
"40 - 59 yrs old",
"More than 60 yrs old"),
Number = c(tmp [1,4],
tmp [1,6],
tmp [1,8],
tmp [1,10]), # f. de c
Rate = c(tmp [1,5],
tmp [1,7],
tmp [1,9],
tmp [1,11]) # f. de c
) # f. de data.frame
Graphe_dfFL3
output$graphe_df <- renderPlotly({
colors <- c('rgb(211,94,96)','rgb(128,133,133)','rgb(144,103,167)','rgb(171,104,87)')
plot_ly(Graphe_dfFL3, labels = ~Ages, values = ~Rate, type = 'pie',
textposition = 'inside',
textinfo = 'label+percent',
insidetextfont = list(color = '#FFFFFF'),
hoverinfo = 'text',
text = ~paste(Ages, ":",Number, "people"),
marker = list(colors = colors,
line = list(color = '#FFFFFF', width = 1)),
showlegend = FALSE) %>%
layout(title = NULL,
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
}) # end of output$graphe_df
} # end of if
}) # end of observeEvent
}) # end of shinyServer
还有styles.CSS:
And the styles.CSS :
div.outer {
position: fixed;
top: 50px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
#controls {
/* Appearance */
background-color: transparent;
padding: 0 20px 20px 20px;
cursor: move;
/* Fade out while not hovering */
opacity: 0;
zoom: 1.0;
transition: opacity 500ms 1s;
}
#controls:hover {
/* Fade in while hovering */
opacity: 1;
transition-delay: 0;
}
您可以在此处找到 shapefile:https://www.dropbox.com/s/mdb6m8hej01ykwp/Ilots_communaux_simples_R.zip?dl=0
You can find the shapefile here : https://www.dropbox.com/s/mdb6m8hej01ykwp/Ilots_communaux_simples_R.zip?dl=0
还有这里的表格:https://www.dropbox.com/s/e3twfm8mwdl9nrg/T_1_2.csv?dl=0
如您所见，我需要获取单击的多边形的PC"值才能正确绘制，但我不知道该怎么做.
As you'll see, I need to get the "PC" value of the polygon I clicked on to plot correctly but I don't know how to do that.
非常感谢您的帮助.
推荐答案
您的示例太大/太复杂，我不喜欢下载外部数据/形状，因此我将其简化为此处的示例.
Your example is too big/complex and I don't fancy downloading external data/shapes, so I've simplified it into the example here.
在我看来，当您单击一个形状时，您想要绘制有关该形状的一些信息.
It seems to me that when you click on a shape, you then want to plot some information about that shape.
在我的示例中，我使用 reactiveValues 来存储可在创建它们的函数之外访问的对象，但也是反应式的.(参见反应性值)
In my example I'm using reactiveValues to store objects that are accessible outside of the function that creates them, but are also reactive. (see reactive values )
因此，当 input$mymap_shape_click 被观察"时，我将创建一个 data.frame 并将其存储在 reactiveValues()对象.
Therefore, when the input$mymap_shape_click is 'observed', I'm creating a data.frame and storing it in a reactiveValues() object.
然后我可以使用任何我想要的 output$... 来响应这个 reactiveValues 对象的变化.在这个例子中，我只是简单地输出一个被点击的形状的纬度/经度表.
I can then use any output$... I want that will react to this reactiveValues object changing. In this example I'm simply outputting a table of the lat/lon of the shape that's clicked.
为了访问所点击形状的 id，您需要在地图上绘制的基础数据中指定一个 id 值.
And in order to access the id of the shape clicked, you need to specify an id value in the underlying data that is plotted on the map.
查看 print 语句的输出，了解单击形状时发生的情况.
See the outputs of the print statements to see what's going on when you click the shapes.
library(shiny)
library(leaflet)
ui <- fluidPage(
leafletOutput(outputId = "mymap"),
tableOutput(outputId = "myDf_output")
)
server <- function(input, output){
## use reactive values to store the data you generate from observing the shape click
rv <- reactiveValues()
rv$myDf <- NULL
cities <- read.csv(textConnection("
City,Lat,Long,Pop
Boston,42.3601,-71.0589,645966
Hartford,41.7627,-72.6743,125017
New York City,40.7127,-74.0059,8406000
Philadelphia,39.9500,-75.1667,1553000
Pittsburgh,40.4397,-79.9764,305841
Providence,41.8236,-71.4222,177994
"))
cities$id <- 1:nrow(cities) ## I'm adding an 'id' value to each shape
output$mymap <- renderLeaflet({
leaflet(cities) %>% addTiles() %>%
addCircles(lng = ~Long, lat = ~Lat, weight = 1,
radius = ~sqrt(Pop) * 30, popup = ~City, layerId = ~id)
})
observeEvent(input$mymap_shape_click, {
print("shape clicked")
event <- input$mymap_shape_click
print(str(event))
## update the reactive value with your data of interest
rv$myDf <- data.frame(lat = event$lat, lon = event$lng)
print(rv$myDf)
})
## you can now 'output' your generated data however you want
output$myDf_output <- renderTable({
rv$myDf
})
}
shinyApp(ui, server)
这篇关于R在传单地图中绘制匹配选定多边形的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
