我开发了一个闪亮的应用程序，该应用程序使用日期范围功能和热图带宽滑块显示传单地图。它工作得很好，但是由于每次重新计算地图时都必须计算热图栅格，因此最终速度很慢。
除了内核密度估计之外，我不想更改通过使用其他函数来计算热图的方式，但是我想知道是否存在更好的方法来主要在服务器的观察函数中构造代码。 / p>
# Libraries --------------------------------------------------------
library(sp)
library(shiny)
library(shinydashboard)
library(leaflet)
library(leaflet.extras)
library(raster)
library(shinycssloaders)
library(shinycustomloader)
library(rgdal)
library(RColorBrewer)
library(shinyWidgets)
library(data.table)
library(KernSmooth)
# Example data--------------------------------------------------------------
long <- c(6.1733,
5.76252,
6.17493,
6.1716,
5.78555,
6.17493,
6.1222721598413,
6.1265145455562,
6.12607352931167,
6.16706)
lat <- c(49.63165,
49.69994,
49.63334,
49.63176,
49.67541,
49.63334,
49.615743071945,
49.6096917834154,
49.6100290844163,
49.63174)
date <- as.Date(c('2018-08-22',
'2018-07-12',
'2018-07-03',
'2018-07-03',
'2018-05-28',
'2018-05-28',
'2018-05-16',
'2018-05-16',
'2018-05-29',
'2018-05-29'))
status <- c('Booked',
'Booked',
'Booked',
'Booked',
'Not Booked',
'Not Booked',
'Not Booked',
'Not Booked',
'Booked',
'Booked')
ex_rds <- data.table(long, lat, status, date)
df_nb <- ex_rds[status == "Not Booked"]
df_b <- ex_rds[status == "Booked"]
# UI ----------------------------------------------------------------------
ui <- dashboardPage(
skin = "red",
dashboardHeader(title = "Bookings and Searches",
titleWidth = 300),
dashboardSidebar(
fluidRow(
column(12, offset = 0,
sliderInput("bwslider",
"Adjust Heatmap Bandwidth",
min = .0005,
max = .004,
step = .0005,
value = .004,
ticks = TRUE))
),
daterange <- dateRangeInput(
inputId = "daterange",
label = "Select the date range",
start = min("2018-04-25"),
end = max("2018-05-25"),
min = min("2018-04-25"),
max = max("2018-11-23"),
format = "yyyy-mm-dd",
separator = "-"),
fluidRow(
column(8, offset = 2,
addSpinner(tableOutput("subdata"), spin = "circle", color = "#FFFFFF")
))
),
dashboardBody(
fluidRow(
tabBox(
id = "tabset1",
height = "95vh",
width = 11.5,
tabPanel(
"Heatmap",
withLoader(leafletOutput("leafletMap", height = "95vh", width = "100%"),
type = "html",
loader = "loader6")
),
tabPanel("Flows",
column(6, leafletOutput("leafletMap2", height = "95vh", width = "100%"))
)
)
)
)
)
# Server -----------------------------------------------------------
bwdf = data.frame("value" = c(.0005, .001, .0015, .002, .0025, .003, .0035, .004))
server <- function(input, output, session) {
bookedData <- reactive({
booked_output <- df_b[df_b$date >= input$daterange[1] &
df_b$date <= input$daterange[2], ]
return(booked_output)
})
notbookedData <- reactive({
notbooked_output <-
df_nb[df_nb$date >= input$daterange[1] &
df_nb$date <= input$daterange[2], ]
return(notbooked_output)
})
bwreact <- reactive({
bw_output <- bwdf[bwdf$value >= input$bwslider, ]
return(bw_output)
})
observe({
bd <- bookedData()
nbd <- notbookedData()
bw <- bwreact()
# Density NB --------------------------------------------------------------
nb_lat <- nbd$lat
nb_lon <- nbd$lon
X <- cbind(nb_lon, nb_lat)
kde2d <-
bkde2D(X,
bandwidth = c(bw, bw),
gridsize = c(2000, 2000)
)
kde2d_raster <- raster::raster(
list(x = kde2d$x1,
y = kde2d$x2,
z = kde2d$fhat)
)
kde2d_raster[kde2d_raster < 50] <- NA
raster::projection(kde2d_raster) <- sp::CRS("+proj=longlat +datum=WGS84")
# Density BD --------------------------------------------------------------
b_lat <- bd$lat
b_lon <- bd$lon
X1 <- cbind(b_lon, b_lat)
kde2d1 <-
bkde2D(X1,
bandwidth = c(bw, bw),
gridsize = c(2000, 2000)
)
kde2d1_raster <- raster::raster(
list(x = kde2d1$x1,
y = kde2d1$x2,
z = kde2d1$fhat)
)
kde2d1_raster[kde2d1_raster < 50] <- NA
raster::projection(kde2d1_raster) <- sp::CRS("+proj=longlat +datum=WGS84")
#leafletProxy --------------------------------------------------
pal <- colorNumeric("RdYlBu", values(kde2d_raster),
na.color = "transparent", reverse = TRUE)
pal2 <- colorNumeric("RdYlBu", values(kde2d1_raster),
na.color = "transparent", reverse = TRUE)
leafletProxy("leafletMap") %>%
clearMarkers() %>%
clearMarkerClusters() %>%
clearShapes() %>%
clearImages() %>%
addAwesomeMarkers(
data = notbookedData(),
lat = nbd$lat,
lng = nbd$lon,
group = "Not Booked",
clusterOptions = markerClusterOptions()
) %>%
addAwesomeMarkers(
data = notbookedData(),
lat = bd$lat,
lng = bd$lon,
group = "Booked",
clusterOptions = markerClusterOptions()
) %>%
addRasterImage(kde2d_raster, opacity = .8, colors = pal, group = "Heatmap Not Booked"
) %>%
addRasterImage(kde2d1_raster, opacity = .8, colors = pal2, group = "Heatmap Booked"
)
})
output$subdata <- renderTable({
s = subset(rides2,
rides2$date >= input$daterange[1] & rides2$date <= input$daterange[2])
table(s$status)
}, colnames = FALSE,
bordered = TRUE)
output$leafletMap <- renderLeaflet({
leaflet(height = "100%") %>%
addTiles(group = "OSM (default)",
options = tileOptions(opacity = .8)) %>%
addProviderTiles(providers$Stamen.Toner, group = "Toner",
options = providerTileOptions(opacity = .2)) %>%
setView(lng = 6.131421, lat = 49.618356 , zoom = 11) %>%
addLayersControl(
baseGroups = c("OSM (default)", "Toner"),
overlayGroups = c(
"Booked",
"Not Booked",
"Heatmap Booked",
"Heatmap Not Booked"
),
options = layersControlOptions(collapsed = FALSE)
) %>%
hideGroup(c("Not Booked", "Heatmap Not Booked"))
})
# Flows ------------------------------------------------------------
# Empty for now
}
# Shiny App --------------------------------------------------------
shinyApp(ui, server)
还有其他一些问题，但主要问题是性能降低。数据导入过程是否会像csv那样出现问题？还是我有来自数据集的两个子集（“ nbd”和“ bd”），从而使计算时间加倍了？任何帮助深表感谢！