二阳大规模来袭,热图地图分析新冠疫情期间的高发地点，掌握防控重点！
一、概述
最近，新冠疫情似乎又要“卷土重来”...
身边逐渐有人传来“二阳”或者“三羊”的消息，网上相关的讨论和报道也变得越来越多。
据「钟南山院士」在大湾区科学论坛上的发言，预测模型seirs显示，第二波新冠疫情已于4月中旬开始，5月底波峰约为每周4000万人次，6月底波峰预计将接近每周6500万人次。这意味着我们需要加强对疫情的警惕，并采取必要的防疫措施，以保护自己和家人的健康。
作为一位R语言医学统计分析科研爱好者，我觉得有必要画出热图地图，作为出行的参考和预测重点的参考！
二、数据获取
library(tidyverse)
library(ggplot2)
library(ggmap)
library(readr)
library(lubridate)
# 读取 COVID-19 数据确诊病例
covid_data <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv")
# 将数据转化为长格式
covid_data_long <- covid_data %>%
pivot_longer(cols = -c(1:4), names_to = "date", values_to = "cases") %>%
mutate(date = mdy(date))
# 转换数据列名
covid_data_long$Country.Region <- covid_data_long$"Country/Region"
start_date <- as.Date("2020-01-01")
end_date <- as.Date("2021-12-31")
# 提取指定日期范围内的数据
covid_data_filtered <- covid_data_long %>%
filter(date >= start_date & date <= end_date) %>%
group_by(Country.Region, Lat, Long) %>%
summarize(cases = sum(cases))
covid_data_filtered
结果显示：
# A tibble: 288 × 4
# Groups: Country.Region, Lat [287]
Country.Region Lat Long cases
1 Afghanistan 33.9 67.7 48020131
2 Albania 41.2 20.2 54833685
3 Algeria 28.0 1.66 67756363
4 Andorra 42.5 1.52 5767152
5 Angola -11.2 17.9 16140555
6 Antarctica -71.9 23.3 198
7 Antigua and Barbuda 17.1 -61.8 712340
8 Argentina -38.4 -63.6 1588547481
9 Armenia 40.1 45.0 100794594
10 Australia -42.9 147. 149920
# ℹ 278 more rows
# ℹ Use `print(n = ...)` to see more rows
三、热图地图生成
3.1 ggmap+ggplot2
# 使用 ggplot2 绘制世界热力图
world <- map_data("world")
world_map <- ggplot() +
# 绘制地图边界和外观
geom_map(data = world, map = world,
aes(map_id = region),
fill = "white", color = "black", size = 0.15) +
# 绘制各国病例数点
geom_point(data = covid_data_filtered,
aes(x = Long, y = Lat, size = cases, color = cases),
alpha = 0.8) +
# 指定热力图颜色范围
scale_color_gradient(low = "#f2f0f7", high = "red") +
# 调整点大小范围
scale_size(range = c(1, 20)) +
# 调整标题、副标题和标注
labs(x = NULL, y = NULL,
title = "World COVID-19 Confirmed Cases Heatmap",
subtitle = "Jan 2020 - Dec 2021",
caption = "Data from Johns Hopkins University Center for Systems Science and Engineering") +
# 调整颜色条样式
theme(legend.position = "bottom") +
# 隐藏背景、网格线和图例框架
theme(panel.background = element_rect(fill = "white"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_blank(),
axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = 20, hjust = 0.5),
plot.subtitle = element_text(size = 15, hjust = 0.5, margin = margin(b = 20)),
plot.caption = element_text(size = 12, color = "gray", hjust = 1, margin = margin(t = 20, l = 20)),
legend.title = element_blank(),
legend.text = element_text(size = 12),
legend.key.width=unit(0.3, "cm"),
legend.key.height=unit(0.3, "cm"),
legend.margin = margin(t = 100),
legend.key = element_rect(fill = "white",color = NA))
world_map
这个结果是可以展示出来，但是不是很美观。
3.2 REmap
3.2.1 安装REmap
# R仓库里面没有这个包，需要从Github上下载
install.packages("devtools")
library(devtools)
install_github('lchiffon/REmap')
library(REmap)
「如果需要安装方法，关注和私信我，欢迎一起讨论学习」
3.2.2 绘制热图remapC
- 数据格式说明：国家/城市+密度
dataC <- subset(covid_data_filtered,select=c(1,4))
dataC_group <- dataC %>%
group_by(Country.Region) %>%
summarize(cases = sum(cases))
data <- data.frame(
country = dataC_group$Country.Region,
value = dataC_group$cases)
# 移除44行，这个数据我也不知道为啥有就报错
data <- data[-44,]
data
结果展示：
country value
1 Afghanistan 48020131
2 Albania 54833685
3 Algeria 67756363
4 Andorra 5767152
5 Angola 16140555
6 Antarctica 198
- 画图
out = remapC(data,maptype = "world",color = 'red')
out
3.2.3 绘制中心热度图remapH
- 数据格式说明：国家/城市+密度
dataH <- subset(covid_data_filtered,select=c(2,3,4))
dataH_group <- dataH %>%
group_by(Lat,Long) %>%
summarize(cases = sum(cases))
data <- data.frame(
lon = dataH_group$Long,
lat = dataH_group$Lat,
prob = dataH_group$cases)
data
结果展示：
lon lat prob
1 23.3470 -71.9499 198
2 -59.5236 -51.7963 26527
3 147.3272 -42.8821 149920
4 174.8860 -40.9006 2068784
5 -63.6167 -38.4161 1588547481
6 144.9631 -37.8136 18904976
- 画图
map_out<-remapH(data,
maptype = 'world',
blurSize = 70,
color = "red",
minAlpha = 10,
opacity = 1,
)
map_out
3.2.4 reportB画出足迹迁徙图（可伸缩）
可以用来追踪感染源的运动足迹！
destination=c("上海","广州","济南","大连","成都","长春","太原","西宁","乌鲁木齐","拉萨")
origin=rep("西安",length(destination))
map_data=data.frame(origin,destination)
画图：
map_out1=remapB(zoom=5,color="dark",title="",subtitle="", markLineData=map_data,markPointData=destination,markLineTheme=markLineControl(symbol=NA,symbolSize=c(0,4),smooth=T, smoothness=0.2,effect = T,lineWidth = 2,lineType="dotted",color="white"),markPointTheme=markPointControl(symbol="heart",symbolSize = "Random",effect = T, effectType = "scale", ))
map_out1
3.2.5 remap迁徙地图
- 数据集
destination=c("济南","北京","郑州","西安","哈尔滨","乌鲁木齐","兰州","成都","长沙")
origin=c("北京","哈尔滨","乌鲁木齐","兰州","成都","长沙","北京","郑州","西安")
map_data=data.frame(origin,destination)
- 画图
map_out=remap(mapdata=map_data,title="",theme=get_theme(theme='Dark'))
map_out
3.2.6 小结
-
「remap」 : 最为基础的一个函数，可绘制路径迁徙图；
-
「remapB」：通过调用百度地图画出一个可通过鼠标进行伸缩的地图；
-
「remapC」：用于创建分级统计图(Choropleth map).即根据子区域数值的多少进行深浅不同的颜色填充的地图形式.目前支持的地图为:‘china’ 中国省份地图；‘world’ 世界地图；各省市地图,如"北京"，常见于疫情防控，阅读数据报表等
-
「remapH」：可以做中心辐射的热力图，这种热力图多用于跟地理信息相关的数据呈现,也可以用来做疫情相关的数据呈现
我愿意称为目前我掌握的包里最好用的地图相关的包，使用简单方便，一行代码，而且图都比较美观大气。
四、未来热图地图的发展和展望
- 数据质量和可靠性的提高
未来热图地图的数据来源将更加稳定，数据检查和分析方法将更加先进，数据可靠性将有所提高。这将使生成的热图地图更加准确地反映实际情况。
- 算法优化和技术创新
随着科技的发展，热图地图算法和技术将不断更新和优化，例如深度学习等技术的应用将推动热图地图更加精确和高效地生成。
- 实用性的提高
热图地图不再局限于一些研究领域的学术用途，而是成为生产生活各大领域，如城市规划、地质勘探、疫情防控等领域的重要工具，逐渐走向实际应用。未来热图地图的实用性将更加突出。
- 可视化和交互性的进一步提高
随着互联网技术的发展，热图地图的可视化和交互性将得到进一步提高，用户可进行更加灵活和便捷的操作，实现更加精准的数据可视化和分析。
总之，未来热图地图将不断发展和创新，为许多领域提供更好的解决方案。
五、疫情防控
虽然人们经历过第一波疫情，但仍需保持警惕，不能放松对病毒的防范。尽管二阳的症状较为轻微，死亡率低，但老年人和儿童等免疫力较弱的人群仍存在严重疾病甚至死亡的风险，因此需要更加重视防护措施。
如果可以的话，希望大家都不要二次感染，因为重复感染不仅可能对身体产生后遗症，还会增加治疗难度和经济负担。因此，我们必须保护自己和家人，尽可能避免感染。在即将到来的第二波疫情感染高峰期间，我们更需要保持警惕，采取必要的防护措施，共同平安渡过这个困难时期。