library(shiny)
library(leaflet)
library(RMySQL)
library(DBI)
data <- function(con){
con <- dbConnect(MySQL(), dbname="", host="localhost",
port = , user="",
password="")
dbSendQuery(con, "SEt NAMES euckr")
d <- dbGetQuery(con, "select * from accidents")
dbDisconnect(con)
}
原始数据(d)有信息:事故发生地点、事故发生年份、事故发生次数、经度、纬度等...
这是用户界面
ui <- navbarPage("Interactive Map",
tabPanel("Map",
leafletOutput("m", height=800),
tags$style("
#controls {
backgropund-color: #ddd;
opacity: 0.7;
}
#controls:hover{
opacity: 1;
}
"),
absolutePanel(id = "controls", class="panel panel-default",
fixed =TRUE, draggable = TRUE, top=60, left="auto",
right=20, bottom ="auto", width=250, height=450,
sliderInput("year",
"years:",
min=min(d$acci_year),
max=max(d$acci_year),
value=range(d$acci_year),
step=1, sep=""))))
这是服务器
server <- function(input, output, session){
filteredData <- reactive({
d[d$acci_year >= input$year[1] & d$acci_year <= input$year[2],]
})
d_colour <- colorFactor("viridis", d$acci_type)
output$m <- renderLeaflet({
leaflet(d) %>%
setView(lng = 126.97806, lat=37.56667, zoom=13) %>%
addTiles() %>%
addCircles(lng=~d$longitude, lat=~d$latitude, color=~d_colour(d$acci_type), radius=20,
popup=paste0("<br>accident place:", d$accident_address, "<br>accident year:", d$acci_year, "<br>발생건수:", d$발생건수,
"<br>사상자수:", d$사상자수, "<br>사망자수:", d$사망자수,
"<br>중상자수:", d$중상자수, "<br>경상자수:", d$경상자수,
"<br>부상자수:", d$부상자수)) %>%
addLegend(position = "bottomleft",
title = "types of accident",
pal = d_colour, values = ~d$acci_type, opacity = 1)
})
d_colour <- colorFactor("viridis", d$acci_type)
observe({
leafletProxy("m", data=filteredData()) %>%
clearShapes() %>%
addCircles(lng=~d$longitude, lat=~d$latitude, color=~d_colour(d$acci_type), radius=20,
popup=paste0("<br>accident place:", d$accident_address, "<br>accident year:", d$acci_year, "<br>발생건수:", d$발생건수,
"<br>사상자수:", d$사상자수, "<br>사망자수:", d$사망자수,
"<br>중상자수:", d$중상자수, "<br>경상자수:", d$경상자수,
"<br>부상자수:", d$부상자수))
})
}
shinyApp(ui=ui, server=server)
我为你把一些变量韩文改成英文了! 由于这个功能一周，我无法进行下一步.. 非常感谢您的回答!!
最佳答案
更新
您的代码中仍然存在错误，您正在替换 map 中的所有点，因此您的 map 不会随 sliderInput 发生变化。您需要通过以下方式更改 lng=~d$longitude, lat=~d$latitude,
lng=~longitude, lat=~latitude, 这意味着您不想在 map ~d$longitude lat=~d$latitude 中添加所有圆圈，而只是由 sliderinput lng=~longitude lat=~latitude 过滤。
当您使用 filteredData() 进行过滤时，您不需要像 d$lat 这样的 d 中的所有信息，例如您是否只需要 SliderInput 过滤的信息:~lat.
旧答案
您的代码中的错误在这里:
leafletProxy("m", data=filteredData()) %>%
clearShapes() %>%
addCircles(lng=~d$longt, lat=~d$lat, color=~d_colour(d$acci_type), # this line
您正在用创建 map 的相同点(d$longt 和 d$lat)替换这些点，因此 map 不会改变。
要解决这个问题，您需要通过 filteredData() 列放置点:
leafletProxy("m", data=filteredData()) %>%
clearShapes() %>% clearMarkers() %>%
addCircles(lng=~longt, lat=~lat, #don't forget ~ to specify that the column comes from filteredData()
color=~d_colour(acci_type),
这里是一个完整的 reproducible example :
library(shiny)
library(leaflet)
d=data.frame(
acci_year=c(2012,2013,2014,2015),
longt=c(126.97806,126.97822126,125.97806,124.97806),
lat=c(37.56667,35.56667,38.56667,37.56667),
acci_type=c("low","high","medium","high"),
accident_happen_place=c("word1","word2","word3","word4"),
accident_2 =c("anotherword1","anotherword2","anotherword3","anotherword4"),
accident_3=c("otheword1","otheword2","otheword3","otheword4"),
accident_4 =c("example1","example2","example3","example4"),
accident_5 =c("anotherexample1","anotherexample2","anotherexample3","anotherexample4"),
accident_6 =c("onemoreexample1","onemoreexample2","onemoreexample3","onemoreexample4"),
accident_7 =c("ex1","ex2","ex3","ex4"),
accident_8 =c("2_ex1","2_ex2","2_ex3","2_ex4")
)
ui <- navbarPage("Interactive Map",
tabPanel("Map",
leafletOutput("m", height=800),
tags$style("
#controls {
backgropund-color: #ddd;
opacity: 0.7;
}
#controls:hover{
opacity: 1;
}
"),
absolutePanel(id = "controls", class="panel panel-default",
fixed =TRUE, draggable = TRUE, top=60, left="auto",
right=20, bottom ="auto", width=250, height=450,
sliderInput("year",
"years:",
min=min(d$acci_year),
max=max(d$acci_year),
value=2012:2019,
step=1, sep=""))))
server <- function(input, output, session){
filteredData <- reactive({
d[d$acci_year >= input$year[1] & d$acci_year <= input$year[2],]
})
d_colour <- colorFactor("viridis", d$acci_type)
output$m <- renderLeaflet({
leaflet(d) %>%
setView(lng = 126.97806, lat=37.56667, zoom=7) %>%
addTiles() %>%
addCircles(lng=~d$longt, lat=~d$lat, color=~d_colour(d$acci_type), radius=20,
popup=paste0("<br>사고장소:", d$accident_happen_place, "<br>accident_2:", d$accident_2, "<br>accident_3:", d$accident_3,
"<br>accident_4:", d$accident_4, "<br>accident_5:", d$accident_5,
"<br>accident_6:", d$accident_6, "<br>accident_7:", d$accident_7,
"<br>accident_8:", d$accident_8)) %>%
addLegend(position = "bottomleft",
title = "사고유형",
pal = d_colour, values = ~d$acci_type, opacity = 1)
})
d_colour <- colorFactor("viridis", d$acci_type)
observe({
leafletProxy("m", data=filteredData()) %>%
clearShapes() %>%
addCircles(lng=~longt, lat=~lat, color=~d_colour(acci_type), radius=20,
popup=paste0("<br>사고장소:", d$accident_happen_place, "<br>발생년도:", d$accident_2, "<br>accident_3:", d$accident_3,
"<br>accident_4:", d$accident_4, "<br>accident_5:", d$accident_5,
"<br>accident_6:", d$accident_6, "<br>accident_7:", d$accident_7,
"<br>accident_8:", d$accident_8) )
} )
}
shinyApp(ui, server)
你不需要使用 dbGetquery 两次:
d <- dbGetQuery(con, "select * from accidents"
dbGetQuery(con,d)
这种方式已经很完美了:
d <- dbGetQuery(con, "select * from accidents")
关于r - 如何在 slider 中过滤 Shiny 传单中的年份(交互式 map )，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/64845445/