我有一个~10,000个地址对（来源，目的地）的数据集，它由两个来源组成 - 数据库和CSV文件。我通过两种不同的标记类型可视化这些地址对，并用线条可视化这些对之间的连接。可以切换原点，目的地和连接的可见性。也可以在地图上绘制多边形以绘制框架标记，然后可视化相应的标记和连接（您可以选择多边形是否应构建原点，目标或两者）。并且可以切换数据源（CSV或数据库）并按日期选择数据。
所有这些都很有效，我只想弄清楚我需要使用无功值的地方。但表现是缓慢的。使用RStudio运行此应用程序时需要花费大量时间才能加载此应用程序，因为连接中断，无法将其加载到Shiny Server上。我没有使用专业版的Shiny Server，其中超时无法立即设置。
我尝试尽可能多地使用leafletProxy加速应用程序。
df.data.db <- getDataFromDb() #external function
df.data.csv <- getDataFromCsv() #external function
df.data.total <- rbind(df.data.db,df.data.csv)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
tags$head(tags$style(HTML('.dest {color: rgba(11, 221, 25, 0.7);}'))),
tags$head(tags$style(HTML('.orig {color: rgba(255,100,20);}'))),
leafletOutput("map", height = "85%"),
fluidRow(
column(
3,
p(tags$b("Datasets")),
materialSwitch(inputId = "useDatabase", label = "database",value=TRUE),
materialSwitch(inputId = "useExcel", label = "excel",value=TRUE)),
column(
3,
p(),
dateRangeInput('dateRange',
label = 'Date range input: yyyy-mm-dd',
start = "2016-12-26",
end = Sys.Date(),
min = "2016-12-26",
max = Sys.Date()),
p(),
textOutput("number_of_data")
),
column(3,
p(),
actionButton("remove", "Remove shapes")),
column(3,
p(tags$b("Connections")),
textOutput("number_of_connections"))
)
)
server <- function(input, output, session) {
reactiveData <- reactiveValues(
markers = data.frame(lat = numeric(), lon = numeric()),
allPoly = data.frame(lat = numeric(), lon = numeric()),#should polygon frame all markers
origPoly = data.frame(lat = numeric(), lon = numeric()),#only origin markers
destPoly = data.frame(lat = numeric(), lon = numeric()),#only destination markers
shapeState = "poly_all",#what polygon type is drawn
connections=0
)
#used subset of data depending of the chosen date
mydata <- reactive({
base = base_data()
from <- input$dateRange[1]
to <- input$dateRange[2]
return(base[base$date>=from & base$date<=to,])
})
#choose data source (csv or db)
base_data <- reactive({
mydf = data.frame(orig_lat=numeric(),
orig_lon=numeric(),
dest_lat=numeric(),
dest_lon=numeric(),
date=as.Date(character()))
if(input$useExcel==TRUE && input$useDatabase==TRUE)
mydf = df.data.total
else if(input$useExcel==FALSE && input$useDatabase==TRUE)
mydf = df.data.db
else if(input$useExcel==TRUE && input$useDatabase==FALSE)
mydf = df.data.csv
reactiveData$connections <- nrow(mydf)
return(mydf)
})
#show / hide connections
observe({
leafletProxy("map",session = session) %>%
clearShapes() %>%
clearGroup("Connections")
conn.data <- mydata();
for(i in 1:nrow(conn.data)) {
row <- conn.data[i,]
leafletProxy("map",session = session) %>% addPolygons(lat=c(row$orig_lat,row$dest_lat),lng=c(row$orig_lon,row$dest_lon),group="Connections",weight=0.5)
}
})
#remove all customized stuff
observeEvent(input$remove,{
reactiveData$markers <- data.frame(lat = numeric(), lon = numeric())
reactiveData$allPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$origPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$destPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$shapeState <- "poly_all"
reactiveData$connections<-0
leafletProxy("map",session = session) %>%
clearShapes() %>%
clearGroup("polygon") %>%
clearGroup("polymarkers")%>%
clearGroup("polyconnections") %>%
showGroup("Origins") %>%
showGroup("Destinations") %>%
clearGroup("tempmarkers")
})
#my map
output$map <- renderLeaflet({
leaflet(data=mydata()) %>%
addTiles()%>%
setView("7.126501","48.609749", 10) %>%
addMarkers(
lng=~dest_lon,
lat=~dest_lat,
icon = uix.destMarker,
group = "Destinations",
layerId = "dest_layer",
clusterId = "dest_cluster",
clusterOptions = markerClusterOptions(
removeOutsideVisibleBounds = TRUE,
iconCreateFunction=js.destclusters
)) %>%
addMarkers(
lng=~orig_lon,
lat=~orig_lat,
icon = uix.origMarker,
group = "Origins",
layerId = "orig_layer",
clusterId = "orig_cluster",
clusterOptions = markerClusterOptions(
removeOutsideVisibleBounds = TRUE,
iconCreateFunction=js.origclusters
)) %>%
addLayersControl(overlayGroups = c("Origins","Destinations","Connections"))
})
#print markers for polygon on map
observeEvent(input$map_click,{
leafletProxy("map",session = session) %>%
hideGroup("Connections")
if(nrow(reactiveData$allPoly)>0){
reactiveData$markers <- data.frame(lat = numeric(), lon = numeric())
reactiveData$allPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$origPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$destPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$shapeState <- "poly_all"
reactiveData$connections<-0
leafletProxy("map",session = session) %>%
clearShapes() %>%
clearGroup("polygon") %>%
clearGroup("polymarkers")%>%
clearGroup("polyconnections") %>%
showGroup("Origins") %>%
showGroup("Destinations") %>%
clearGroup("tempmarkers")
}
if(nrow(reactiveData$origPoly)>0 && nrow(reactiveData$destPoly)>0){
showModal(modalDialog(
title = "Wrong workflow",
"Remove old shapes first!",
easyClose = TRUE
))
}
else{
click <- input$map_click
clat <- click$lat
clng <- click$lng
reactiveData$markers[nrow(reactiveData$markers) + 1, ] = c(clat, clng)
leafletProxy('map') %>%
addMarkers(lng = reactiveData$markers$lon,
lat = reactiveData$markers$lat,
group="polymarkers"
)
}
})
#change type of polygon by clicking on polygon. hiding connections by clicking on it
observeEvent(input$map_shape_click,{
click <- input$map_shape_click
if(click$group=="Connections"){
leafletProxy("map",session = session) %>%
hideGroup("Connections")
clat <- click$lat
clng <- click$lng
leafletProxy('map') %>%
addMarkers(lng = clng,
lat = clat)
reactiveData$markers[nrow(reactiveData$markers) + 1, ] = c(clat, clng)
}
else if(click$group =="polygon" && nrow(reactiveData$markers)==0){
tmp <- data.frame(lat = numeric(), lon = numeric())
if(reactiveData$shapeState=="poly_all") {
reactiveData$shapeState<-"poly_orig"
isolate(tmp<-reactiveData$allPoly)
reactiveData$origPoly <- rbind(reactiveData$origPoly,tmp)
reactiveData$allPoly<- data.frame(lat = numeric(), lon = numeric())
#reactiveData$destPoly <- rbind(reactiveData$destPoly,data.frame(lat = numeric(), lon = numeric()))
}
else if(reactiveData$shapeState=="poly_orig") {
reactiveData$shapeState<-"poly_dest"
isolate(tmp<-reactiveData$origPoly)
reactiveData$origPoly <- data.frame(lat = numeric(), lon = numeric())
#reactiveData$allPoly <- data.frame(lat = numeric(), lon = numeric())
reactiveData$destPoly <- rbind(reactiveData$destPoly,tmp)
}
else if(reactiveData$shapeState=="poly_dest") {
reactiveData$shapeState<-"poly_all"
isolate(tmp<-reactiveData$destPoly)
#reactiveData$origPoly <- rbind(reactiveData$origPoly,data.frame(lat = numeric(), lon = numeric()))
reactiveData$allPoly <- rbind(reactiveData$allPoly,tmp)
reactiveData$destPoly <- data.frame(lat = numeric(), lon = numeric())
}
createConnections()
leafletProxy('map') %>% # use the proxy to save computation
clearGroup("polygon") %>%
addPolygons(lat = tmp$lat, lng = tmp$lon, group="polygon",color = polyColor(),fillColor=polyColor())
}
else if(nrow(reactiveData$markers)>0){
showModal(modalDialog(
title = "Wrong workflow",
"It's too late to change the type of your selection. Please clear shapes and draw again!",
easyClose = TRUE
))
}
})
polyColor <- reactive({
if(reactiveData$shapeState=="poly_all") {
return("black")
}
else if(reactiveData$shapeState=="poly_orig") {
return("red")
}
else if(reactiveData$shapeState=="poly_dest") {
return("green")
}
})
createConnections <- reactive({
reactiveData$connections<-0
df.pois <- data.frame(lat=numeric(),lon=numeric())
data <- mydata()
allData <- data.frame(orig_lat=numeric(),
orig_lon=numeric(),
dest_lat=numeric(),
dest_lon=numeric(),
date=as.Date(character()))
if(nrow(reactiveData$allPoly)>0){
df.pois<-rbind(data.frame(lat=data$orig_lat, lon=data$orig_lon),
data.frame(lat=data$dest_lat, lon=data$dest_lon))
my_poly <- reactiveData$allPoly
pois <- SpatialPoints(df.pois)
poiPoly <- SpatialPolygons(list(Polygons(list(
Polygon(cbind(my_poly$lat, my_poly$lon))
), ID = "x11")))
coords<-as.data.frame(pois[poiPoly])
if(nrow(coords)>0){
allData1<-subset(data,((data$orig_lat %in% coords$lat)))
allData1<-subset(allData1,((allData1$orig_lon %in% coords$lon)))
allData2<-subset(data,((data$dest_lat %in% coords$lat)))
allData2<-subset(allData2,((allData2$dest_lon %in% coords$lon)))
allData<-rbind(allData1,allData2)
}
}else {
if(nrow(reactiveData$origPoly)>0){
df.pois<-data.frame(lat=data$orig_lat, lon=data$orig_lon)
my_poly <- reactiveData$origPoly
pois <- SpatialPoints(df.pois)
poiPoly <- SpatialPolygons(list(Polygons(list(
Polygon(cbind(my_poly$lat, my_poly$lon))
), ID = "x11")))
coords<-as.data.frame(pois[poiPoly])
allData1<-subset(data,((data$orig_lat %in% coords$lat)))
allData1<-subset(allData1,((allData1$orig_lon %in% coords$lon)))
allData<-allData1
data<-allData
}
if(nrow(reactiveData$destPoly)>0){
df.pois<-data.frame(lat=data$dest_lat, lon=data$dest_lon)
my_poly <- reactiveData$destPoly
pois <- SpatialPoints(df.pois)
poiPoly <- SpatialPolygons(list(Polygons(list(
Polygon(cbind(my_poly$lat, my_poly$lon))
), ID = "x11")))
coords<-as.data.frame(pois[poiPoly])
total <- mydata()
allData2<-subset(data,((data$dest_lat %in% coords$lat)))
allData2<-subset(allData2,((allData2$dest_lon %in% coords$lon)))
allData<-allData2
}
}
leafletProxy("map",session = session) %>%
clearGroup("polyconnections")
leafletProxy("map",session = session) %>%
hideGroup("Origins") %>%
hideGroup("Destinations") %>%
clearGroup("tempmarkers")
if(nrow(allData)>0){
reactiveData$connections<-nrow(allData)
leafletProxy("map",session = session,data=allData) %>%
addMarkers(
lng=~dest_lon,
lat=~dest_lat,
icon = uix.destMarker,
group = "tempmarkers"
) %>%
addMarkers(
lng=~orig_lon,
lat=~orig_lat,
icon = uix.origMarker,
group = "tempmarkers"
)
for(i in 1:nrow(allData)) {
row <- allData[i,]
leafletProxy("map",session = session) %>%
addPolygons(lat=c(row$orig_lat,row$dest_lat),lng=c(row$orig_lon,row$dest_lon),group="polyconnections",weight=1)
}
}
})
observeEvent(input$map_marker_click, {
my_poly <- data.frame(lat=numeric(),lon=numeric())
if (nrow(reactiveData$markers) >= 4) {
my_poly <- rbind(my_poly,reactiveData$markers)
if(reactiveData$shapeState=="poly_all") {
reactiveData$allPoly <- rbind(reactiveData$allPoly,my_poly)
}
else if(reactiveData$shapeState=="poly_orig") {
reactiveData$destPoly <- rbind(reactiveData$destPoly,my_poly)
reactiveData$shapeState = "poly_dest"
}
else if(reactiveData$shapeState=="poly_dest") {
reactiveData$origPoly <- rbind(reactiveData$origPoly,my_poly)
reactiveData$shapeState = "poly_orig"
}
leafletProxy('map') %>% # use the proxy to save computation
addPolygons(lat = my_poly$lat, lng = my_poly$lon, group="polygon",color = polyColor(),fillColor=polyColor())
createConnections()
reactiveData$markers <- data.frame(lat=numeric(),lon=numeric())
}
})
}
shinyApp(ui, server)
我不认为10.000对的数据集是＆＃34;大＆＃34;对于统计数据而言，我非常确定R的设计足以处理这么多数据，所以我猜它的传单本身或我对传单或反应数据的错误使用。 我也不太确定原点和目的地之间的线条的创建，这也需要花费很多时间，但我找不到一种更简单的方法来在传单上的两点之间画一条简单的线条。
for(i in 1:nrow(conn.data)) {
row <- conn.data[i,]
leafletProxy("map",session = session) %>% addPolygons(lat=c(row$orig_lat,row$dest_lat),lng=c(row$orig_lon,row$dest_lon),group="Connections",weight=0.5)
}