alex/Population_Study
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Minor updates of names

Browse Source
This commit is contained in:
Alex Gebben Work 2025-12-10 13:58:35 -07:00
parent f2bc4dd516
commit 00cac36c46
3 changed files with 21 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
2B_Result_Analysis.r
View File

@ -15,28 +15,28 @@ source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Function
POP_DATA <- GET_DATA(RES,3) POP_DATA <- GET_DATA(RES,3)
POP_PLOT <- MAKE_GRAPH(POP_DATA) POP_PLOT <- MAKE_GRAPH(POP_DATA)
POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
POP_PLOT POP_PLOT
dev.off() dev.off()
BIRTH_DATA <- GET_DATA(RES,4) BIRTH_DATA <- GET_DATA(RES,4)
BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA) BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA)
BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
BIRTH_PLOT BIRTH_PLOT
dev.off() dev.off()
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN)) DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA) DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA)
DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
DEATH_PLOT DEATH_PLOT
dev.off() dev.off()
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN)) MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA) MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA)
MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
MIGRATION_PLOT MIGRATION_PLOT
dev.off() dev.off()
@ -46,7 +46,7 @@ KEY <- RES %>% filter(Year %in% c(2029,2030,2035,2045,2055,2065))
AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean")) AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean"))
HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 10000, by = 500)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1)) HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 10000, by = 500)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1))
png(paste0(SAVE_RES_LOC,"Population_Histogram.png"), width = 8, height = 12, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Histogram_Main_Results.png"), width = 8, height = 12, units = "in", res = 600)
HISTOGRAM HISTOGRAM
dev.off() dev.off()
@ -67,6 +67,6 @@ PLOT_YELLOW <- "yellow"
PLOT_RED <- "red" PLOT_RED <- "red"
KEY_YEARS <- KEY_YEARS%>% as.data.frame KEY_YEARS <- KEY_YEARS%>% as.data.frame
Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity")) Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity"))
gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Main_Results/Capacity_Table.html") gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Main_Results/Capacity_Table_Main_Results.html")
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 85mm --page-height 328mm ./Results/Primary_Simulation_Results/Main_Results/Capacity_Table.html ./Results/Primary_Simulation_Results/Main_Results/Capacity_Table.pdf") system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 85mm --page-height 328mm ./Results/Primary_Simulation_Results/Main_Results/Capacity_Table_Main_Results.html ./Results/Primary_Simulation_Results/Main_Results/Capacity_Table_Main_Results.pdf")

14
2C_Upper_Bound_Result_Analysis.r
View File

@ -16,28 +16,28 @@ source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Function
POP_DATA <- GET_DATA(RES,3) POP_DATA <- GET_DATA(RES,3)
POP_PLOT <- MAKE_GRAPH(POP_DATA,COLOR='springgreen4') POP_PLOT <- MAKE_GRAPH(POP_DATA,COLOR='springgreen4')
POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
POP_PLOT POP_PLOT
dev.off() dev.off()
BIRTH_DATA <- GET_DATA(RES,4) BIRTH_DATA <- GET_DATA(RES,4)
BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA,COLOR='springgreen4') BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA,COLOR='springgreen4')
BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
BIRTH_PLOT BIRTH_PLOT
dev.off() dev.off()
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN)) DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA,COLOR='springgreen4') DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA,COLOR='springgreen4')
DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
DEATH_PLOT DEATH_PLOT
dev.off() dev.off()
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN)) MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA,COLOR='springgreen4') MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA,COLOR='springgreen4')
MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
MIGRATION_PLOT MIGRATION_PLOT
dev.off() dev.off()
@ -47,7 +47,7 @@ KEY <- RES %>% filter(Year %in% c(2029,2030,2035,2045,2055,2065))
AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean")) AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean"))
HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_fill_gradient(low = "grey", high = "darkgreen")+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 100000, by = 1000)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1)) HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_fill_gradient(low = "grey", high = "darkgreen")+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 100000, by = 1000)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1))
png(paste0(SAVE_RES_LOC,"Population_Histogram.png"), width = 8, height = 12, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Histogram_Upper_Bound.png"), width = 8, height = 12, units = "in", res = 600)
HISTOGRAM HISTOGRAM
dev.off() dev.off()
@ -68,6 +68,6 @@ PLOT_YELLOW <- "yellow"
PLOT_RED <- "red" PLOT_RED <- "red"
KEY_YEARS <- KEY_YEARS%>% as.data.frame KEY_YEARS <- KEY_YEARS%>% as.data.frame
Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity")) Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity"))
gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table.html") gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table_Upper_Bound.html")
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 85mm --page-height 328mm ./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table.html ./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table.pdf") system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 85mm --page-height 328mm ./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table_Upper_Bound.html ./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table_Upper_Bound.pdf")

14
2D_Lower_Bound_Result_Analysis.r
View File

@ -16,28 +16,28 @@ source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Function
POP_DATA <- GET_DATA(RES,3) POP_DATA <- GET_DATA(RES,3)
POP_PLOT <- MAKE_GRAPH(POP_DATA,COLOR='firebrick2') POP_PLOT <- MAKE_GRAPH(POP_DATA,COLOR='firebrick2')
POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) POP_PLOT <- POP_PLOT+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ggtitle("Kemmerer & Diamondville, Population Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Population")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
POP_PLOT POP_PLOT
dev.off() dev.off()
BIRTH_DATA <- GET_DATA(RES,4) BIRTH_DATA <- GET_DATA(RES,4)
BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA,COLOR='firebrick2') BIRTH_PLOT <- MAKE_GRAPH(BIRTH_DATA,COLOR='firebrick2')
BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) BIRTH_PLOT <- BIRTH_PLOT+geom_line(data=HIST,aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Birth Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Births")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
BIRTH_PLOT BIRTH_PLOT
dev.off() dev.off()
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN)) DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA,COLOR='firebrick2') DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA,COLOR='firebrick2')
DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) DEATH_PLOT <- DEATH_PLOT+geom_line(data=HIST,aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ggtitle("Kemmerer & Diamondville, Mortality Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Deaths")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
DEATH_PLOT DEATH_PLOT
dev.off() dev.off()
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN)) MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA,COLOR='firebrick2') MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA,COLOR='firebrick2')
MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank()) MIGRATION_PLOT <- MIGRATION_PLOT+geom_line(data=HIST,aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_x_continuous(breaks = c(seq(2010, 2060, by = 5),2065),limits=c(2009,2065))+ scale_y_continuous(breaks = seq(-1000, 1000, by = 50))+ggtitle("Kemmerer & Diamondville, Net Migration Forecast")+ expand_limits( y = 0)+labs(color = "Prediction Interval",linetype="Prediction Interval",y="Migration")+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart.png"), width = 12, height = 8, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
MIGRATION_PLOT MIGRATION_PLOT
dev.off() dev.off()
@ -47,7 +47,7 @@ KEY <- RES %>% filter(Year %in% c(2029,2030,2035,2045,2055,2065))
AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean")) AVG_VALUES <- rbind(AVG_VALUES[,1:2]%>% rename(Value=MED) %>% mutate('Summary Stat.'="Median"),AVG_VALUES[,c(1,3)] %>% rename(Value=MEAN) %>% mutate('Summary Stat.'="Mean"))
HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_fill_gradient(low = "grey", high = "darkred")+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 10000, by = 500)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1)) HISTOGRAM <- ggplot(KEY, aes(x = Population,group=-Year,Color=Year,fill=Year)) + geom_histogram(alpha=0.3,bins=800)+geom_vline(data = AVG_VALUES, aes(xintercept = Value,group=`Summary Stat.`,color = `Summary Stat.`), size = 0.75)+scale_fill_gradient(low = "grey", high = "darkred")+scale_color_manual(values=c("red","black","black"))+ facet_grid(rows=vars(Year))+ scale_x_continuous(breaks = c(seq(0, 10000, by = 500)))+ theme_bw()+ theme(legend.position = "top",panel.grid.minor = element_blank())+ylab("Number of Simulation")+guides(fill= guide_legend(nrow = 1))
png(paste0(SAVE_RES_LOC,"Population_Histogram.png"), width = 8, height = 12, units = "in", res = 600) png(paste0(SAVE_RES_LOC,"Population_Histogram_Lower_Bound.png"), width = 8, height = 12, units = "in", res = 600)
HISTOGRAM HISTOGRAM
dev.off() dev.off()
@ -68,6 +68,6 @@ PLOT_YELLOW <- "yellow"
PLOT_RED <- "red" PLOT_RED <- "red"
KEY_YEARS <- KEY_YEARS%>% as.data.frame KEY_YEARS <- KEY_YEARS%>% as.data.frame
Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity")) Capacity_Risk <- KEY_YEARS%>% gt(rownames_to_stub = TRUE,caption="Year") %>% data_color( fn = scales::col_numeric( palette = c(PLOT_RED, PLOT_YELLOW, PLOT_GREEN), domain = c(0, 1) ) ) %>% fmt_percent( decimals = 1, drop_trailing_zeros = FALSE) %>% tab_stubhead(label =c("Capacity"))
gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table.html") gtsave( data = Capacity_Risk , filename = "./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.html")
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 85mm --page-height 328mm ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table.html ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table.pdf") system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 89mm --page-height 328mm ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.html ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.pdf")