“活”预测线和CI丝带成动画

编程问答 2022-05-16

问题描述

**大家好， 我正在研究芬兰的 CoVid 数据。 我曾在某处看到一个动画示例，其中 (1)（例如黄土）预测线和（置信区间带）出现在实际观测值之前。 (2) FC 变化。这真的很酷，当预测随时间变化时，即随着时间的推移，fc 和色带“扭曲”和“生活”。 如果有人能帮我生成一个，我真的很感激。

（我们在这里的新冠疫情状态非常好，但各个地区处于非常不同的阶段。现在数据科学非常受欢迎**

以下代码

##0 图书馆现在

library(ggplot2)
library(haven)
library(dplyr)
library(gganimate)
library(gifski)
library(lubridate)
library(RColorBrewer)
library(rgl)
library(rjstat)
library(scales)
library(magick)
library(stats)

#1。从 FIN 健康统计办公室检索数据所需的前“周”

weeks<-"509242.509085.508582.509058.508933.508786.509057.508587.509081.509236.508610.508960.508538.508787.508611.509163.509183.509140.509164.508519.509017.508496.509240.509239.508839.509327.509321.508926.508489.509060.509028.509186.508692.508503.508666.508870.508743.508761.509095.509116.508937.509061.508573.508721.509050.508991.508964.508741.509323.508547.509079.508800.508872.509096.509115.509159.509087.509065.508494.508853.508675.508844.508834.508921."

2.然后从数据库中检索数据

现在计算黄土线而不是 CI（Confindece Intervals） 让我们以 2 个地区（实际上是整个芬兰和其中最大的地区）为例（在绘制平面图时）

####Positives weekly FIN
url_test_cases <- "https://sampo.thl.fi/pivot/prod/fi/epirapo/covid19case/fact_epirapo_covid19case.json"
request_test_row <- "?row=hcdmunicipality2020-445222.&"
request_test_column<-"column=dateweek20200101-"
request_measure<-"&filter=measure-444833"
#request_measure<-"&filter=measure-492118"
url <- paste0(url_test_cases,request_test_row,request_test_column,weeks,request_measure)
casecubeweeks <- fromJSONstat(url,naming = "label",use_factors = F,silent = T)
dfcasesFINweeks <- casecubeweeks[[1]]
dfcasesFINweeks$Postivesweeksly<-as.numeric(dfcasesFINweeks$value)
dfcasesFINweeks$rate<-(dfcasesFINweeks$Postivesweeksly/5542092)
dfcasesFINweeks_wo_na<-na.omit(dfcasesFINweeks)
dfcasesFINweeks_wo_na$dateweek20200101_num <- as.numeric(gsub("[^[:digit:]]+","",dfcasesFINweeks_wo_na$dateweek20200101))
dfcasesFINweeks_wo_na$time<-as.Date(paste(dfcasesFINweeks_wo_na$dateweek20200101_num,1),"%Y%U %u")
dfcasesFINweeks_wo_na$pop<-(1*5542092)
FINbyWweek<-dfcasesFINweeks_wo_na
FINbyWweek$Region<-(1*1)
FINbyWweek$datenum<-as.numeric(FINbyWweek$time)
FINbyWweek <- FINbyWweek[complete.cases(FINbyWweek[,c("rate","time","value")]),]
smooth_vals=predict(loess(rate~datenum,FINbyWweek,span=0.5))
FINbyWweek$smooth<-smooth_vals
FINcases<-FINbyWweek


####Positives weekly HUS
url_test_cases <- "https://sampo.thl.fi/pivot/prod/fi/epirapo/covid19case/fact_epirapo_covid19case.json"
request_test_row <- "?row=hcdmunicipality2020-445193.&"
request_test_column<-"column=dateweek20200101-"
request_measure<-"&filter=measure-444833"
#request_measure<-"&filter=measure-492118"
url <- paste0(url_test_cases,silent = T)
dfcasesHUSweeks <- casecubeweeks[[1]]
dfcasesHUSweeks$Postivesweeksly<-as.numeric(dfcasesHUSweeks$value)
dfcasesHUSweeks$rate<-(dfcasesHUSweeks$Postivesweeksly/1697302)
dfcasesHUSweeks_wo_na<-na.omit(dfcasesHUSweeks)
dfcasesHUSweeks_wo_na$dateweek20200101_num <- as.numeric(gsub("[^[:digit:]]+",dfcasesHUSweeks_wo_na$dateweek20200101))
dfcasesHUSweeks_wo_na$time<-as.Date(paste(dfcasesHUSweeks_wo_na$dateweek20200101_num,"%Y%U %u")
dfcasesHUSweeks_wo_na$pop<-(1*1697302)
HUSbyWweek<-dfcasesHUSweeks_wo_na
HUSbyWweek$Region<-(1*2)
HUSbyWweek$datenum<-as.numeric(HUSbyWweek$time)
HUSbyWweek <- HUSbyWweek[complete.cases(HUSbyWweek[,HUSbyWweek,span=0.5))
HUSbyWweek$smooth<-smooth_vals
HUScases<-HUSbyWweek

#Join the two regions

FINJAHUScases<-bind_rows(
FINbyWweek,HUSbyWweek)

3 绘图和动画（构面） 我真的希望 FC 线和 CI 功能区在观察前 3-4 周出现。 也有颜色的传说会很棒（vlines 造成了一些麻烦

    FINJAHUScases$vari<-as.factor(FINJAHUScases$Region)
FINJAHUScases$koko<-as.factor(FINJAHUScases$Region)

summary(FINJAHUScases)


    ggplot_animate<-ggplot(FINJAHUScases,aes(x=FINJAHUScases$time,FINJAHUScases$rate*100000,size=FINJAHUScases$koko,colour=FINJAHUScases$vari))+
      geom_line()+
      geom_line(aes(group=koko,y = FINJAHUScases$smooth*100000),colour = "firebrick",size=2) +
      geom_vline(data= FINJAHUScases,aes(group=koko,xintercept = as.numeric(FINJAHUScases$time[6])),linetype="dashed",color="navyblue",size=1.0)+
      geom_text(data= FINJAHUScases,x=FINJAHUScases$time[3],y=100),angle=90,label="Uudenmaan sulku alkaa",size=3)+
      #annotate("text",x=FINJAHUScases$time[2],y=120,vjust=1.2,parse=T)+
      geom_vline(data= FINJAHUScases,xintercept = as.numeric(FINJAHUScases$time[8])),color="darkgreen",x=FINJAHUScases$time[10],y=120),label="1.ravintolasulku alkaa",size=3)+
      geom_vline(data= FINJAHUScases,xintercept = as.numeric(FINJAHUScases$time[58])),color="orangered",x=FINJAHUScases$time[56],y=50),label="2.ravintolasulku alkaa",x=FINJAHUScases$time[54],y=80,parse=F)+
      #geom_smooth(method="auto",col="blue",span = 2)+
      #geom_point(aes(group = rev(seq_along(LAP_weekly_go$datenum)))) +
      #geom_point(aes(group = rev(LAP_weekly_go$datenum))) +
      #geom_hline(yintercept = 50,color="black",size=0.5)+
      #geom_hline(yintercept = 100,size=0.75)+
      #ylim(0,160)+
      scale_size_manual(name="Alueet:",values=c("1"=1,"2"=1,"3"=1,"4"=1,"5"=1,"6"=1,"7"=1,"8"=1,"9"=1,"10"=1,"11"=1,"12"=1,"13"=1,"14"=1,"15"=1,"16"=1,"17"=1,"18"=1,"19"=1,"20"=1,"21"=1,"22"=1),labels=c("1"="1-Koko maa","2"="2-HUS","3"="3-Lapin","4"="4-Länsi-Pohjan","5"="5-Kainuun","6"="6-Pohjois-Pohjanmaan","7"="7-Keski-Pohjanmaan","8"="8-Vaasan","9"="9-Etelä-Pohjanmaan","10"="10-Keski-Suomen","11"="11-Pohjois-Savon","12"="12-Pohjois-Karjalan","13"="13-Itä-Savon","14"="14-Etelä-Savon","15"="15-Etelä-Karjalan","16"="16-Kymenlaakson","17"="17-Päijät-Hämeen","18"="18-Pirkanmaan","19"="19-Kanta-Hämeen","20"="20-Satakunnan","21"="21-Varsinais-Suomen","22"="22-Ahvenanmaa"
                        ))+
      scale_color_manual(name="Sairaanhoitopiiri",values = c("1"="darkgoldenrod3","2"="firebrick2","3"="brown","4"="chocolate","5"="blue1","6"="darkgray","7"="darkgreen","8"="gold","9"="dodgerblue","10"="darkviolet","11"="gray48","12"="green","13"="lightblue","14"="khaki","15"="blue","16"="olivedrab","17"="orange","18"="orangered","19"="royalblue","20"="salmon","21"="sienna","22"="steelblue"),"22"="22-Ahvenanmaa"
                         ))+
      facet_grid(row=factor(FINJAHUScases$koko),scales = "free_y")+
      guides(color="none")+
      #guides(colour = guide_legend("Sairaanhoitopiirit"))+
      #guides(color=guide_legend(override.aes = list(size=4)))+
      #guides(size = "none")+
      theme(legend.position = "bottom")+
      ggtitle("Covid-19 tautitapaukset/100.000 henkeä / viikko")+
      scale_x_date(date_breaks = "1 month",date_labels="%b")+
      theme(plot.title = element_text(hjust = 0.5))+
      xlab("Aika")+
      ylab("Tautitapauksia/väestö")+
      labs(caption = "J.Jukola  Lähde: THL")+
      #ylim(0,0.0015)+
      #transition_reveal(datedate)
      #transition_states(LAP_weekly_go$datenum) 
      transition_reveal(datenum)
    #+ shadow_mark()
    #view_follow(fixed_x = T)+
    #labs(title = "Covid-tautitapaukset sairaanhoitopiireittäin: {frame_time}")
    #shadow_wake(wake_length = 0.6,alpha=0.8)
    #shadow_trail(past=T)
    
    
    animate(ggplot_animate,height = 800,width = 600,duration = 20,fps=4,end_pause=20,renderer = magick_renderer())

###==========================THX!!!

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

animationfacetloessrribbon

相关问答

matplotlib报错：AttributeError: module 'backend_interagg' has no attribute 'FigureCanvas'. Did you mean: 'FigureCanvasAgg'?
使用本地python环境可以成功执行 import pandas as pd impor...
gitlab登录失败，报错：This challenge page was accidentally cached by an intermediary and is no longer available.
设置时间 控制面板
后端开发常见错误
错误1：Request method ‘DELETE‘ not supported 错误还原：...
docker常见错误
错误1：启动docker镜像时报错：Error response from daemon:...
idea常见错误
错误1：private field ‘xxx‘ is never assigned 按Alt...
pip安装依赖失败
报错如下，通过源不能下载，最后警告pip需升级版本 Requirem...