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
还有样式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.
然后我可以使用任何我想对reactiveValues
对象更改做出反应的output$...
.在此示例中,我仅输出一张被单击形状的经度/纬度表.
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屋!