Cleaned up and fixed error
This commit is contained in:
Alex Gebben Work
parent
cacb64a657
commit
69e42fbb25
@ -1,192 +0,0 @@
|
|||||||
#####Packages
|
|
||||||
library(tidyverse) #Cleaning data
|
|
||||||
library(fixest) #Estimating a model of birth rates, to provide variance in the birth rate Monte Carlo using a fixed effect model.
|
|
||||||
library(forecast) #Fore ARIMA migration simulations
|
|
||||||
library(parallel)
|
|
||||||
library(uuid) #To add a index to each batch
|
|
||||||
####If the preliminary data needs to be reloaded run the supplied bash script to download, process, and generate all needed data sets for the Monte Carlo population Simulation. Otherwise skip this step to save time
|
|
||||||
RELOAD_DATA <- FALSE
|
|
||||||
if(RELOAD_DATA){system("bash Prelim_Process.sh")}
|
|
||||||
|
|
||||||
#Load custom functions needed for the simulation
|
|
||||||
source("Scripts/Load_Custom_Functions/Migration_Simulation_Functions.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Birth_Simulation_Functions.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Increment_Data_Year.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Single_Age_Mortality_Trend_Simulation.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Induced_Migration_Functions.r")
|
|
||||||
|
|
||||||
#######Preliminary Model Inputs
|
|
||||||
YEARS_AHEAD <- 41
|
|
||||||
ST_YEAR <- 2025
|
|
||||||
################################Load Data
|
|
||||||
DEMO <- readRDS("Data/Intermediate_Inputs/Starting_Demographic_Data_Sets_of_Monte_Carlo/2024_Starting_Kemmerer_Diamondville_Demographics_Matrix.Rds")
|
|
||||||
|
|
||||||
BIRTH_MOD <- readRDS("Data/Intermediate_Inputs/Birth_Regressions/Birth_Regression.Rds")
|
|
||||||
#Must add region as a factor with multiple levels for predict to work. Seems to check for multiple levels although that is not needed econometrics.
|
|
||||||
BIRTH_DATA <- readRDS("Data/Intermediate_Inputs/Birth_Regressions/Regression_Data/Birth_Simulation_Key_Starting_Points.Rds") %>% mutate(Region=factor(Region)) %>% filter(KEM==1,Year==2023) %>% mutate(Year=2024)
|
|
||||||
|
|
||||||
|
|
||||||
MIGRATION_ARIMA <- readRDS("Data/Intermediate_Inputs/Migration_ARIMA_Models/Kemmerer_Diamondville_Net_Migration_ARIMA.Rds")
|
|
||||||
MIGRATION_ODDS <- readRDS("Data/Intermediate_Inputs/Migration_Trends/Migration_Age_Probability_Zero_to_85.Rds")
|
|
||||||
####
|
|
||||||
OPERATORS <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Operating_Worker_Related_Migration.Rds")
|
|
||||||
CONSTRUCTION <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Construction_Related_Migration.Rds")
|
|
||||||
OPERATOR_LIN_MIGRATION <- OPERATORS %>% pull("Operator_Emp_Migrated")
|
|
||||||
CONSTRUCTION_LIN_MIGRATION <- CONSTRUCTION %>% pull("Construction_Emp_Migrated")
|
|
||||||
|
|
||||||
INDUCED_MIGRATION_MULTIPLIERS <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Induced_Jobs.Rds")
|
|
||||||
|
|
||||||
##############
|
|
||||||
#Data for death rate trends
|
|
||||||
SINGLE_AGE_MODS <- readRDS("Data/Intermediate_Inputs/Mortality_Regression_Data/Single_Sex_Age_Time_Series_Regression.Rds")
|
|
||||||
BOUNDS <- readRDS("Data/Intermediate_Inputs/Mortality_Regression_Data/Single_Sex_Age_Bounds_for_Predictions.Rds")
|
|
||||||
MAX_MALE <- BOUNDS %>% filter(Sex=='Male') %>% pull(MAX_RATE)
|
|
||||||
MIN_MALE <- BOUNDS %>% filter(Sex=='Male') %>% pull(MIN_RATE)
|
|
||||||
MAX_FEMALE <- BOUNDS %>% filter(Sex=='Female') %>% pull(MAX_RATE)
|
|
||||||
MIN_FEMALE <- BOUNDS %>% filter(Sex=='Female') %>% pull(MIN_RATE)
|
|
||||||
MIN_GAP <- BOUNDS %>% filter(Sex=='Male') %>% pull(MIN_MALE_FEMALE_GAP)
|
|
||||||
MAX_GAP <- BOUNDS %>% filter(Sex=='Male') %>% pull(MAX_MALE_FEMALE_GAP)
|
|
||||||
BASELINE_AGE_ADJUST_MEN <- readRDS("Data/Cleaned_Data/Mortality_Data/RDS/Single_Sex_Age_Population_in_2000.Rds") %>% filter(Sex=='Male') %>% pull(Percent_of_Population)
|
|
||||||
BASELINE_AGE_ADJUST_WOMEN <- readRDS("Data/Cleaned_Data/Mortality_Data/RDS/Single_Sex_Age_Population_in_2000.Rds") %>% filter(Sex=='Female') %>% pull(Percent_of_Population)
|
|
||||||
#Adjust to just women popualtion (Not all population percent
|
|
||||||
BASELINE_AGE_ADJUST_WOMEN <- BASELINE_AGE_ADJUST_WOMEN/sum(BASELINE_AGE_ADJUST_WOMEN )
|
|
||||||
BASELINE_AGE_ADJUST_MEN <- BASELINE_AGE_ADJUST_MEN/ sum(BASELINE_AGE_ADJUST_MEN )
|
|
||||||
MOD_MEN_ALL <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_US_Men_Mortality_by_Age.Rds")
|
|
||||||
MOD_WOMEN_ALL <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_US_Women_Mortality_by_Age.Rds")
|
|
||||||
MOD_LIN_MEN <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_Lincoln_Men_Mortality_by_Age.Rds")
|
|
||||||
MOD_LIN_WOMEN <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_Lincoln_Women_Mortality_by_Age.Rds")
|
|
||||||
XREG <- cbind(rep(0.0001,YEARS_AHEAD+1),rep(0.0001,YEARS_AHEAD+1)) #Empty data set to simulate in the future
|
|
||||||
XREG <- ts(XREG,start=ST_YEAR,frequency=1)
|
|
||||||
SIMULATE_MORTALITY_RATE_TRENDS <- function(){
|
|
||||||
SIMULATED_MORTALITY_DATA_SET <- MAKE_EMPTY(ST_YEAR,ST_YEAR+YEARS_AHEAD,MOD_LIN_MEN,MOD_LIN_WOMEN,MOD_MEN_ALL,MOD_WOMEN_ALL,XREG)
|
|
||||||
MORTALITY_SIMULATION <- AGE_DIST(SINGLE_AGE_MODS,SIMULATED_MORTALITY_DATA_SET ,MAX_MALE,MAX_FEMALE,MIN_MALE,MIN_FEMALE,MAX_GAP,MIN_GAP,BASELINE_AGE_ADJUST_MEN,BASELINE_AGE_ADJUST_WOMEN)
|
|
||||||
return(MORTALITY_SIMULATION )
|
|
||||||
}
|
|
||||||
|
|
||||||
#####################START YEAR BY SIMULATIONS
|
|
||||||
#CURRENT_YEARS_AHEAD=1;CURRENT_SIM_NUM <- 1;MORTALITY_SIMULATION <- SIMULATE_MORTALITY_RATE_TRENDS()
|
|
||||||
SINGLE_YEAR_SIM <- function(DEMO,BIRTH_DATA,CURRENT_YEARS_AHEAD,MORTALITY_SIMULATION,NET_MIGRATION){
|
|
||||||
ORIG_DEMO <- DEMO
|
|
||||||
DEMO <- DEMOGRAPHICS_AFTER_MIGRATION(DEMO, NET_MIGRATION,MIGRATION_ODDS )
|
|
||||||
TOTAL_MIGRATION <- sum(DEMO-ORIG_DEMO)
|
|
||||||
BIRTH_DATA$Year <- BIRTH_DATA$Year+1
|
|
||||||
BIRTH_DATA$Lag_Two_Births <- BIRTH_DATA$Lag_Births
|
|
||||||
BIRTH_DATA$Lag_Births <- BIRTH_DATA$Births
|
|
||||||
BIRTH_DATA$Births <- NA
|
|
||||||
##We grab one year earlier than the window because they are one year older this year. Because the ages are from 0-85, row 18 is year 17, but one year is added making it 18 years in the current year. The birth windows are 18-28 for women and 18-30 for men.
|
|
||||||
BIRTH_DATA$Min_Birth_Group <- min(sum(DEMO[18:30,1]),sum(DEMO[18:28,2]))
|
|
||||||
NEW_BORNS <- BIRTH_SIM(BIRTH_MOD,BIRTH_DATA)
|
|
||||||
TOTAL_BIRTHS <- sum(NEW_BORNS)
|
|
||||||
BIRTH_DATA[,"Births"] <- TOTAL_BIRTHS
|
|
||||||
DEMO <- INCREMENT_AGES(DEMO,NEW_BORNS)
|
|
||||||
MORTALITY_SIMULATION
|
|
||||||
MALE_DEATHS <- sapply(1:86,function(x){rbinom(1,DEMO[x,1],MORTALITY_SIMULATION[[1]][x,CURRENT_YEARS_AHEAD])})
|
|
||||||
FEMALE_DEATHS <- sapply(1:86,function(x){rbinom(1,DEMO[x,2],MORTALITY_SIMULATION[[2]][x,CURRENT_YEARS_AHEAD])})
|
|
||||||
MALE_DEATHS <- ifelse(MALE_DEATHS>=DEMO[,1],DEMO[,1],MALE_DEATHS)
|
|
||||||
FEMALE_DEATHS <- ifelse(FEMALE_DEATHS>=DEMO[,1],DEMO[,1],FEMALE_DEATHS)
|
|
||||||
|
|
||||||
TOTAL_DEATHS <- sum(MALE_DEATHS+FEMALE_DEATHS)
|
|
||||||
DEMO[,"Num_Male"] <- DEMO[,"Num_Male"] -MALE_DEATHS
|
|
||||||
DEMO[,"Num_Female"] <- DEMO[,"Num_Female"] -FEMALE_DEATHS
|
|
||||||
#List of values needed for the next run or for reporting a result
|
|
||||||
TOTAL_POP <- sum(DEMO)
|
|
||||||
return(list(DEMO,BIRTH_DATA,c(TOTAL_POP,TOTAL_BIRTHS,TOTAL_DEATHS,TOTAL_MIGRATION)))
|
|
||||||
}
|
|
||||||
|
|
||||||
MIGRATION_ARIMA_MODEL <- MIGRATION_ARIMA
|
|
||||||
#DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA_MODEL,OPERATOR_TOTAL,CONSTRUCTION_TOTAL,MIGRATION_MULTIPLIERS
|
|
||||||
CONSTRUCTION_MIGRATION <- CONSTRUCTION_LIN_MIGRATION
|
|
||||||
MIGRATION_MULTIPLIERS <- INDUCED_MIGRATION_MULTIPLIERS
|
|
||||||
OPERATOR_MIGRATION <- OPERATOR_LIN_MIGRATION
|
|
||||||
|
|
||||||
SINGLE_SIM <- function(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA_MODEL,OPERATOR_MIGRATION,CONSTRUCTION_MIGRATION,MIGRATION_MULTIPLIERS ){
|
|
||||||
|
|
||||||
TERRA_POWER_EFFECT <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED <- rep(0,YEARS_AHEAD)
|
|
||||||
OPERATOR_MIGRATION <- LOCAL_WORK_ADJ(OPERATOR_MIGRATION ,0.85) #Assume between 85%-100% operators live in Kemmerer
|
|
||||||
CONSTRUCTION_MIGRATION <- LOCAL_WORK_ADJ(CONSTRUCTION_MIGRATION,0.41) #Assume between 41%-100% operators live in Kemmerer
|
|
||||||
CONSTRUCTION_MIGRATION[7] <- CONSTRUCTION_MIGRATION[7] - sum(CONSTRUCTION_MIGRATION )
|
|
||||||
CONSTRUCTION_POPULATION_ADDED <- cumsum(CONSTRUCTION_MIGRATION)
|
|
||||||
ADDED_FROM_BASELINE <- runif(1) #The percentage of the possible growth in industries like restaurants to add compared to the Kemmerer IMPLAN model which understates possible structural growth
|
|
||||||
PERMANENT_TERRAPOWER_MIGRATION <- INDUCED_SIMULATION(CONSTRUCTION_MIGRATION,OPERATOR_MIGRATION,MIGRATION_MULTIPLIERS,ADDED_FROM_BASELINE)+OPERATOR_MIGRATION
|
|
||||||
|
|
||||||
###############NOTE NEED TO USE THIS AT END TO ADJUST THE RESULTS WHILE LEAVING THE DEMOGRAPHIC MATRIX
|
|
||||||
TERRA_POWER_EFFECT[1:7] <- TERRA_POWER_EFFECT[1:7]+CONSTRUCTION_MIGRATION
|
|
||||||
#Dry Pine Migration
|
|
||||||
DRY_PINE <- round(runif(1,0.15,0.45)*c(126,176,-302)*1.15)
|
|
||||||
DRY_PINE[3] <- DRY_PINE[3]-sum(DRY_PINE)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[2:4] <- DRY_PINE
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[2:4] <- cumsum(DRY_PINE)
|
|
||||||
#Data Center Simulation
|
|
||||||
if(runif(1)>0.67){
|
|
||||||
MW_CAPACITY <- runif(1,20,120)
|
|
||||||
PERM_WORKERS <- MW_CAPACITY/8+30 #Seems to be a good ration 32.5 workers at 20 capacity and 45 at max this is a heurstic I came up with
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM
|
|
||||||
DATA_CENTER_START_YEAR <- which.max(runif(YEARS_AHEAD-6))+3
|
|
||||||
PERM_DATA_CENTER_OP <- PERM_WORKERS*(1+(2.515334+19.52286*ADDED_FROM_BASELINE)/40) #Add induced
|
|
||||||
#Estimate construction workers on data center
|
|
||||||
AVG_CONST_COST_PER_MW <- (10.4+13.2)/2
|
|
||||||
RELATIVE_COST_DRAW <- runif(1,10.4*0.75,13.2*1.25)/AVG_CONST_COST_PER_MW #Draw from the range of reported construction costs per MW of capacity in Cheyene. See "DATA CENTER DEVELOPMENT COST GUIDE"
|
|
||||||
PERCENT_IN_KEMMERER <- runif(1,0.41,1) #What percent of the in migration will live in Kemmerer vs other areas. Taken from TerraPower assumptions
|
|
||||||
POP_PER_YEAR <- (1.15*46.02*MW_CAPACITY)/3 #MW capacity ranges from 18 to 120 based on historic Sabre projects. IMPLAN estimates 46.02 total jobs, per MW of capacity (using average cost per MWh). 1.15 accounts for 5% of workers bringing families
|
|
||||||
TEMP_DATA_MIGRATION <- round(PERCENT_IN_KEMMERER*RELATIVE_COST_DRAW*(POP_PER_YEAR))
|
|
||||||
|
|
||||||
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+3] <- OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+3]+TEMP_DATA_MIGRATION #Enter
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+6] <- OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+6]-TEMP_DATA_MIGRATION #Leave
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[(DATA_CENTER_START_YEAR+3):(DATA_CENTER_START_YEAR+5)]<- OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[(DATA_CENTER_START_YEAR+3):(DATA_CENTER_START_YEAR+5)]+TEMP_DATA_MIGRATION
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM[DATA_CENTER_START_YEAR+6] <- OTHER_PROJECT_EFFECTS_PERM[DATA_CENTER_START_YEAR+3]+PERM_DATA_CENTER_OP
|
|
||||||
}
|
|
||||||
MIGRATION_SIM_VALUES <- round(as.vector(simulate(nsim=YEARS_AHEAD,MIGRATION_ARIMA_MODEL))+TERRA_POWER_EFFECT+OTHER_PROJECT_EFFECTS_PERM)
|
|
||||||
#The runif applies a downshift ranging from the historic decline rate all the way to the Lincoln rate applied in the model
|
|
||||||
|
|
||||||
FINAL_REPORT_VALUES <- matrix(NA,ncol=6,nrow=YEARS_AHEAD)
|
|
||||||
colnames(FINAL_REPORT_VALUES ) <- c("Sim_UUID","Year","Population","Births","Deaths","Net_Migration")
|
|
||||||
FINAL_REPORT_VALUES[,1] <- UUIDgenerate()
|
|
||||||
for(i in 1:YEARS_AHEAD){
|
|
||||||
C_YEAR <- ST_YEAR+i-1
|
|
||||||
C_RES <-SINGLE_YEAR_SIM(DEMO,BIRTH_DATA,i,SIMULATE_MORTALITY_RATE_TRENDS(),MIGRATION_SIM_VALUES[i])
|
|
||||||
DEMO <- C_RES[[1]]
|
|
||||||
BIRTH_DATA <- C_RES[[2]]
|
|
||||||
FINAL_REPORT_VALUES[i,-1] <- c(C_YEAR,C_RES[[3]])
|
|
||||||
}
|
|
||||||
FINAL_REPORT_VALUES[1:7,3] <- as.numeric(FINAL_REPORT_VALUES[1:7,3])+CONSTRUCTION_POPULATION_ADDED
|
|
||||||
FINAL_REPORT_VALUES[1:7,6] <- as.numeric(FINAL_REPORT_VALUES[1:7,6]) +CONSTRUCTION_MIGRATION
|
|
||||||
|
|
||||||
FINAL_REPORT_VALUES[,6] <- as.numeric(FINAL_REPORT_VALUES[,6]) +OTHER_PROJECT_EFFECTS_TEMP[1:nrow(FINAL_REPORT_VALUES)]
|
|
||||||
FINAL_REPORT_VALUES[,3] <- as.numeric(FINAL_REPORT_VALUES[,3]) +OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[1:nrow(FINAL_REPORT_VALUES)]
|
|
||||||
return(FINAL_REPORT_VALUES)
|
|
||||||
}
|
|
||||||
|
|
||||||
if(!exists("RES_DIR")){RES_DIR<- "./Results/"}
|
|
||||||
if(!exists("RES_SIM_DIR")){RES_SIM_DIR <- paste0(RES_DIR,"Simulations/")}
|
|
||||||
dir.create(RES_SIM_DIR, recursive = TRUE, showWarnings = FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
NCORES <- detectCores()-1
|
|
||||||
BATCH_SIZE <- NCORES*10
|
|
||||||
TOTAL_SIMULATIONS <- 10^5
|
|
||||||
N_RUNS <-ceiling(TOTAL_SIMULATIONS/BATCH_SIZE )
|
|
||||||
|
|
||||||
SIM_RES_FILE <- paste0(RES_SIM_DIR,"Kemmerer_2024_Upper_Bound_With_Data_Center_Simulation.csv")
|
|
||||||
NEW_RES_FILE <- !file.exists(SIM_RES_FILE)
|
|
||||||
OPERATOR_LIN_MIGRATION <- OPERATORS %>% pull("Operator_Emp_Migrated")
|
|
||||||
CONSTRUCTION_LIN_MIGRATION <- CONSTRUCTION %>% pull("Construction_Emp_Migrated")
|
|
||||||
|
|
||||||
for(i in 1:N_RUNS){
|
|
||||||
# MIGRATION_MATRIX <- simulate(nsim=BATCH_SIZE,MIGRATION_ARIMA,n=YEARS_AHEAD)
|
|
||||||
MIGRATION_MATRIX <- do.call(cbind, mclapply(1:BATCH_SIZE,function(x)(as.vector(simulate(nsim=YEARS_AHEAD,MIGRATION_ARIMA) )),mc.cores = detectCores()-1))
|
|
||||||
# rownames(MIGRATION_MATRIX) <- ST_YEAR:(ST_YEAR+YEARS_AHEAD-1)
|
|
||||||
# colnames(MIGRATION_MATRIX) <- 1:BATCH_SIZE
|
|
||||||
#SINGLE_SIM(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA,OPERATOR_LIN_MIGRATION,CONSTRUCTION_LIN_MIGRATION,INDUCED_MIGRATION_MULTIPLIERS)
|
|
||||||
try(RES <- do.call(rbind,mclapply(1:BATCH_SIZE,function(x){SINGLE_SIM(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA,OPERATOR_LIN_MIGRATION,CONSTRUCTION_LIN_MIGRATION,INDUCED_MIGRATION_MULTIPLIERS)},mc.cores=NCORES)))
|
|
||||||
if(exists("RES")){
|
|
||||||
RES <- as.data.frame(RES)
|
|
||||||
RES[,-1] <- as.numeric(as.matrix(RES[,-1]))
|
|
||||||
if(NEW_RES_FILE & i==1){write_csv(RES,SIM_RES_FILE)}else {write_csv(RES,SIM_RES_FILE,col_names=FALSE,append=TRUE)}
|
|
||||||
rm(RES)
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
@ -1,192 +0,0 @@
|
|||||||
#####Packages
|
|
||||||
library(tidyverse) #Cleaning data
|
|
||||||
library(fixest) #Estimating a model of birth rates, to provide variance in the birth rate Monte Carlo using a fixed effect model.
|
|
||||||
library(forecast) #Fore ARIMA migration simulations
|
|
||||||
library(parallel)
|
|
||||||
library(uuid) #To add a index to each batch
|
|
||||||
####If the preliminary data needs to be reloaded run the supplied bash script to download, process, and generate all needed data sets for the Monte Carlo population Simulation. Otherwise skip this step to save time
|
|
||||||
RELOAD_DATA <- FALSE
|
|
||||||
if(RELOAD_DATA){system("bash Prelim_Process.sh")}
|
|
||||||
|
|
||||||
#Load custom functions needed for the simulation
|
|
||||||
source("Scripts/Load_Custom_Functions/Migration_Simulation_Functions.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Birth_Simulation_Functions.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Increment_Data_Year.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Single_Age_Mortality_Trend_Simulation.r")
|
|
||||||
source("Scripts/Load_Custom_Functions/Induced_Migration_Functions.r")
|
|
||||||
|
|
||||||
#######Preliminary Model Inputs
|
|
||||||
YEARS_AHEAD <- 41
|
|
||||||
ST_YEAR <- 2025
|
|
||||||
################################Load Data
|
|
||||||
DEMO <- readRDS("Data/Intermediate_Inputs/Starting_Demographic_Data_Sets_of_Monte_Carlo/2024_Starting_Kemmerer_Diamondville_Demographics_Matrix.Rds")
|
|
||||||
|
|
||||||
BIRTH_MOD <- readRDS("Data/Intermediate_Inputs/Birth_Regressions/Birth_Regression.Rds")
|
|
||||||
#Must add region as a factor with multiple levels for predict to work. Seems to check for multiple levels although that is not needed econometrics.
|
|
||||||
BIRTH_DATA <- readRDS("Data/Intermediate_Inputs/Birth_Regressions/Regression_Data/Birth_Simulation_Key_Starting_Points.Rds") %>% mutate(Region=factor(Region)) %>% filter(KEM==1,Year==2023) %>% mutate(Year=2024)
|
|
||||||
|
|
||||||
|
|
||||||
MIGRATION_ARIMA <- readRDS("Data/Intermediate_Inputs/Migration_ARIMA_Models/Kemmerer_Diamondville_Net_Migration_ARIMA.Rds")
|
|
||||||
MIGRATION_ODDS <- readRDS("Data/Intermediate_Inputs/Migration_Trends/Migration_Age_Probability_Zero_to_85.Rds")
|
|
||||||
####
|
|
||||||
OPERATORS <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Operating_Worker_Related_Migration.Rds")
|
|
||||||
CONSTRUCTION <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Construction_Related_Migration.Rds")
|
|
||||||
OPERATOR_LIN_MIGRATION <- OPERATORS %>% pull("Operator_Emp_Migrated")
|
|
||||||
CONSTRUCTION_LIN_MIGRATION <- CONSTRUCTION %>% pull("Construction_Emp_Migrated")
|
|
||||||
|
|
||||||
INDUCED_MIGRATION_MULTIPLIERS <- readRDS("Data/Cleaned_Data/TerraPower_Impact/Induced_Jobs.Rds")
|
|
||||||
|
|
||||||
##############
|
|
||||||
#Data for death rate trends
|
|
||||||
SINGLE_AGE_MODS <- readRDS("Data/Intermediate_Inputs/Mortality_Regression_Data/Single_Sex_Age_Time_Series_Regression.Rds")
|
|
||||||
BOUNDS <- readRDS("Data/Intermediate_Inputs/Mortality_Regression_Data/Single_Sex_Age_Bounds_for_Predictions.Rds")
|
|
||||||
MAX_MALE <- BOUNDS %>% filter(Sex=='Male') %>% pull(MAX_RATE)
|
|
||||||
MIN_MALE <- BOUNDS %>% filter(Sex=='Male') %>% pull(MIN_RATE)
|
|
||||||
MAX_FEMALE <- BOUNDS %>% filter(Sex=='Female') %>% pull(MAX_RATE)
|
|
||||||
MIN_FEMALE <- BOUNDS %>% filter(Sex=='Female') %>% pull(MIN_RATE)
|
|
||||||
MIN_GAP <- BOUNDS %>% filter(Sex=='Male') %>% pull(MIN_MALE_FEMALE_GAP)
|
|
||||||
MAX_GAP <- BOUNDS %>% filter(Sex=='Male') %>% pull(MAX_MALE_FEMALE_GAP)
|
|
||||||
BASELINE_AGE_ADJUST_MEN <- readRDS("Data/Cleaned_Data/Mortality_Data/RDS/Single_Sex_Age_Population_in_2000.Rds") %>% filter(Sex=='Male') %>% pull(Percent_of_Population)
|
|
||||||
BASELINE_AGE_ADJUST_WOMEN <- readRDS("Data/Cleaned_Data/Mortality_Data/RDS/Single_Sex_Age_Population_in_2000.Rds") %>% filter(Sex=='Female') %>% pull(Percent_of_Population)
|
|
||||||
#Adjust to just women popualtion (Not all population percent
|
|
||||||
BASELINE_AGE_ADJUST_WOMEN <- BASELINE_AGE_ADJUST_WOMEN/sum(BASELINE_AGE_ADJUST_WOMEN )
|
|
||||||
BASELINE_AGE_ADJUST_MEN <- BASELINE_AGE_ADJUST_MEN/ sum(BASELINE_AGE_ADJUST_MEN )
|
|
||||||
MOD_MEN_ALL <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_US_Men_Mortality_by_Age.Rds")
|
|
||||||
MOD_WOMEN_ALL <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_US_Women_Mortality_by_Age.Rds")
|
|
||||||
MOD_LIN_MEN <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_Lincoln_Men_Mortality_by_Age.Rds")
|
|
||||||
MOD_LIN_WOMEN <- readRDS("Data/Intermediate_Inputs/Age_Mortality_ARIMA_Models/ARIMA_Lincoln_Women_Mortality_by_Age.Rds")
|
|
||||||
XREG <- cbind(rep(0.0001,YEARS_AHEAD+1),rep(0.0001,YEARS_AHEAD+1)) #Empty data set to simulate in the future
|
|
||||||
XREG <- ts(XREG,start=ST_YEAR,frequency=1)
|
|
||||||
SIMULATE_MORTALITY_RATE_TRENDS <- function(){
|
|
||||||
SIMULATED_MORTALITY_DATA_SET <- MAKE_EMPTY(ST_YEAR,ST_YEAR+YEARS_AHEAD,MOD_LIN_MEN,MOD_LIN_WOMEN,MOD_MEN_ALL,MOD_WOMEN_ALL,XREG)
|
|
||||||
MORTALITY_SIMULATION <- AGE_DIST(SINGLE_AGE_MODS,SIMULATED_MORTALITY_DATA_SET ,MAX_MALE,MAX_FEMALE,MIN_MALE,MIN_FEMALE,MAX_GAP,MIN_GAP,BASELINE_AGE_ADJUST_MEN,BASELINE_AGE_ADJUST_WOMEN)
|
|
||||||
return(MORTALITY_SIMULATION )
|
|
||||||
}
|
|
||||||
|
|
||||||
#####################START YEAR BY SIMULATIONS
|
|
||||||
#CURRENT_YEARS_AHEAD=1;CURRENT_SIM_NUM <- 1;MORTALITY_SIMULATION <- SIMULATE_MORTALITY_RATE_TRENDS()
|
|
||||||
SINGLE_YEAR_SIM <- function(DEMO,BIRTH_DATA,CURRENT_YEARS_AHEAD,MORTALITY_SIMULATION,NET_MIGRATION){
|
|
||||||
ORIG_DEMO <- DEMO
|
|
||||||
DEMO <- DEMOGRAPHICS_AFTER_MIGRATION(DEMO, NET_MIGRATION,MIGRATION_ODDS )
|
|
||||||
TOTAL_MIGRATION <- sum(DEMO-ORIG_DEMO)
|
|
||||||
BIRTH_DATA$Year <- BIRTH_DATA$Year+1
|
|
||||||
BIRTH_DATA$Lag_Two_Births <- BIRTH_DATA$Lag_Births
|
|
||||||
BIRTH_DATA$Lag_Births <- BIRTH_DATA$Births
|
|
||||||
BIRTH_DATA$Births <- NA
|
|
||||||
##We grab one year earlier than the window because they are one year older this year. Because the ages are from 0-85, row 18 is year 17, but one year is added making it 18 years in the current year. The birth windows are 18-28 for women and 18-30 for men.
|
|
||||||
BIRTH_DATA$Min_Birth_Group <- min(sum(DEMO[18:30,1]),sum(DEMO[18:28,2]))
|
|
||||||
NEW_BORNS <- BIRTH_SIM(BIRTH_MOD,BIRTH_DATA)
|
|
||||||
TOTAL_BIRTHS <- sum(NEW_BORNS)
|
|
||||||
BIRTH_DATA[,"Births"] <- TOTAL_BIRTHS
|
|
||||||
DEMO <- INCREMENT_AGES(DEMO,NEW_BORNS)
|
|
||||||
MORTALITY_SIMULATION
|
|
||||||
MALE_DEATHS <- sapply(1:86,function(x){rbinom(1,DEMO[x,1],MORTALITY_SIMULATION[[1]][x,CURRENT_YEARS_AHEAD])})
|
|
||||||
FEMALE_DEATHS <- sapply(1:86,function(x){rbinom(1,DEMO[x,2],MORTALITY_SIMULATION[[2]][x,CURRENT_YEARS_AHEAD])})
|
|
||||||
MALE_DEATHS <- ifelse(MALE_DEATHS>=DEMO[,1],DEMO[,1],MALE_DEATHS)
|
|
||||||
FEMALE_DEATHS <- ifelse(FEMALE_DEATHS>=DEMO[,1],DEMO[,1],FEMALE_DEATHS)
|
|
||||||
|
|
||||||
TOTAL_DEATHS <- sum(MALE_DEATHS+FEMALE_DEATHS)
|
|
||||||
DEMO[,"Num_Male"] <- DEMO[,"Num_Male"] -MALE_DEATHS
|
|
||||||
DEMO[,"Num_Female"] <- DEMO[,"Num_Female"] -FEMALE_DEATHS
|
|
||||||
#List of values needed for the next run or for reporting a result
|
|
||||||
TOTAL_POP <- sum(DEMO)
|
|
||||||
return(list(DEMO,BIRTH_DATA,c(TOTAL_POP,TOTAL_BIRTHS,TOTAL_DEATHS,TOTAL_MIGRATION)))
|
|
||||||
}
|
|
||||||
|
|
||||||
MIGRATION_ARIMA_MODEL <- MIGRATION_ARIMA
|
|
||||||
#DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA_MODEL,OPERATOR_TOTAL,CONSTRUCTION_TOTAL,MIGRATION_MULTIPLIERS
|
|
||||||
CONSTRUCTION_MIGRATION <- CONSTRUCTION_LIN_MIGRATION
|
|
||||||
MIGRATION_MULTIPLIERS <- INDUCED_MIGRATION_MULTIPLIERS
|
|
||||||
OPERATOR_MIGRATION <- OPERATOR_LIN_MIGRATION
|
|
||||||
|
|
||||||
SINGLE_SIM <- function(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA_MODEL,OPERATOR_MIGRATION,CONSTRUCTION_MIGRATION,MIGRATION_MULTIPLIERS ){
|
|
||||||
|
|
||||||
TERRA_POWER_EFFECT <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP <- rep(0,YEARS_AHEAD)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED <- rep(0,YEARS_AHEAD)
|
|
||||||
OPERATOR_MIGRATION <- LOCAL_WORK_ADJ(OPERATOR_MIGRATION ,0.85) #Assume between 85%-100% operators live in Kemmerer
|
|
||||||
CONSTRUCTION_MIGRATION <- LOCAL_WORK_ADJ(CONSTRUCTION_MIGRATION,0.41) #Assume between 41%-100% operators live in Kemmerer
|
|
||||||
CONSTRUCTION_MIGRATION[7] <- CONSTRUCTION_MIGRATION[7] - sum(CONSTRUCTION_MIGRATION )
|
|
||||||
CONSTRUCTION_POPULATION_ADDED <- cumsum(CONSTRUCTION_MIGRATION)
|
|
||||||
ADDED_FROM_BASELINE <- runif(1) #The percentage of the possible growth in industries like restaurants to add compared to the Kemmerer IMPLAN model which understates possible structural growth
|
|
||||||
PERMANENT_TERRAPOWER_MIGRATION <- INDUCED_SIMULATION(CONSTRUCTION_MIGRATION,OPERATOR_MIGRATION,MIGRATION_MULTIPLIERS,ADDED_FROM_BASELINE)+OPERATOR_MIGRATION
|
|
||||||
|
|
||||||
###############NOTE NEED TO USE THIS AT END TO ADJUST THE RESULTS WHILE LEAVING THE DEMOGRAPHIC MATRIX
|
|
||||||
TERRA_POWER_EFFECT[1:7] <- TERRA_POWER_EFFECT[1:7]+CONSTRUCTION_MIGRATION
|
|
||||||
#Dry Pine Migration
|
|
||||||
DRY_PINE <- round(runif(1,0.15,0.45)*c(126,176,-302)*1.15)
|
|
||||||
DRY_PINE[3] <- DRY_PINE[3]-sum(DRY_PINE)
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[2:4] <- DRY_PINE
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[2:4] <- cumsum(DRY_PINE)
|
|
||||||
#Data Center Simulation
|
|
||||||
if(runif(1)>0.67){
|
|
||||||
MW_CAPACITY <- runif(1,20,120)
|
|
||||||
PERM_WORKERS <- MW_CAPACITY/8+30 #Seems to be a good ration 32.5 workers at 20 capacity and 45 at max this is a heurstic I came up with
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM
|
|
||||||
DATA_CENTER_START_YEAR <- which.max(runif(YEARS_AHEAD-6))+3
|
|
||||||
PERM_DATA_CENTER_OP <- PERM_WORKERS*(1+(2.515334+19.52286*ADDED_FROM_BASELINE)/40) #Add induced
|
|
||||||
#Estimate construction workers on data center
|
|
||||||
AVG_CONST_COST_PER_MW <- (10.4+13.2)/2
|
|
||||||
RELATIVE_COST_DRAW <- runif(1,10.4*0.75,13.2*1.25)/AVG_CONST_COST_PER_MW #Draw from the range of reported construction costs per MW of capacity in Cheyene. See "DATA CENTER DEVELOPMENT COST GUIDE"
|
|
||||||
PERCENT_IN_KEMMERER <- runif(1,0.41,1) #What percent of the in migration will live in Kemmerer vs other areas. Taken from TerraPower assumptions
|
|
||||||
POP_PER_YEAR <- (1.15*46.02*MW_CAPACITY)/3 #MW capacity ranges from 18 to 120 based on historic Sabre projects. IMPLAN estimates 46.02 total jobs, per MW of capacity (using average cost per MWh). 1.15 accounts for 5% of workers bringing families
|
|
||||||
TEMP_DATA_MIGRATION <- round(PERCENT_IN_KEMMERER*RELATIVE_COST_DRAW*(POP_PER_YEAR))
|
|
||||||
|
|
||||||
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+3] <- OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+3]+TEMP_DATA_MIGRATION #Enter
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+6] <- OTHER_PROJECT_EFFECTS_TEMP[DATA_CENTER_START_YEAR+6]-TEMP_DATA_MIGRATION #Leave
|
|
||||||
OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[(DATA_CENTER_START_YEAR+3):(DATA_CENTER_START_YEAR+5)]<- OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[(DATA_CENTER_START_YEAR+3):(DATA_CENTER_START_YEAR+5)]+TEMP_DATA_MIGRATION
|
|
||||||
OTHER_PROJECT_EFFECTS_PERM[DATA_CENTER_START_YEAR+6] <- OTHER_PROJECT_EFFECTS_PERM[DATA_CENTER_START_YEAR+3]+PERM_DATA_CENTER_OP
|
|
||||||
}
|
|
||||||
MIGRATION_SIM_VALUES <- round(as.vector(simulate(nsim=YEARS_AHEAD,MIGRATION_ARIMA_MODEL))-55+TERRA_POWER_EFFECT+OTHER_PROJECT_EFFECTS_PERM)
|
|
||||||
#The runif applies a downshift ranging from the historic decline rate all the way to the Lincoln rate applied in the model
|
|
||||||
|
|
||||||
FINAL_REPORT_VALUES <- matrix(NA,ncol=6,nrow=YEARS_AHEAD)
|
|
||||||
colnames(FINAL_REPORT_VALUES ) <- c("Sim_UUID","Year","Population","Births","Deaths","Net_Migration")
|
|
||||||
FINAL_REPORT_VALUES[,1] <- UUIDgenerate()
|
|
||||||
for(i in 1:YEARS_AHEAD){
|
|
||||||
C_YEAR <- ST_YEAR+i-1
|
|
||||||
C_RES <-SINGLE_YEAR_SIM(DEMO,BIRTH_DATA,i,SIMULATE_MORTALITY_RATE_TRENDS(),MIGRATION_SIM_VALUES[i])
|
|
||||||
DEMO <- C_RES[[1]]
|
|
||||||
BIRTH_DATA <- C_RES[[2]]
|
|
||||||
FINAL_REPORT_VALUES[i,-1] <- c(C_YEAR,C_RES[[3]])
|
|
||||||
}
|
|
||||||
FINAL_REPORT_VALUES[1:7,3] <- as.numeric(FINAL_REPORT_VALUES[1:7,3])+CONSTRUCTION_POPULATION_ADDED
|
|
||||||
FINAL_REPORT_VALUES[1:7,6] <- as.numeric(FINAL_REPORT_VALUES[1:7,6]) +CONSTRUCTION_MIGRATION
|
|
||||||
|
|
||||||
FINAL_REPORT_VALUES[,6] <- as.numeric(FINAL_REPORT_VALUES[,6]) +OTHER_PROJECT_EFFECTS_TEMP[1:nrow(FINAL_REPORT_VALUES)]
|
|
||||||
FINAL_REPORT_VALUES[,3] <- as.numeric(FINAL_REPORT_VALUES[,3]) +OTHER_PROJECT_EFFECTS_TEMP_POP_ADDED[1:nrow(FINAL_REPORT_VALUES)]
|
|
||||||
return(FINAL_REPORT_VALUES)
|
|
||||||
}
|
|
||||||
|
|
||||||
if(!exists("RES_DIR")){RES_DIR<- "./Results/"}
|
|
||||||
if(!exists("RES_SIM_DIR")){RES_SIM_DIR <- paste0(RES_DIR,"Simulations/")}
|
|
||||||
dir.create(RES_SIM_DIR, recursive = TRUE, showWarnings = FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
NCORES <- detectCores()-1
|
|
||||||
BATCH_SIZE <- NCORES*10
|
|
||||||
TOTAL_SIMULATIONS <- 10^5
|
|
||||||
N_RUNS <-ceiling(TOTAL_SIMULATIONS/BATCH_SIZE )
|
|
||||||
|
|
||||||
SIM_RES_FILE <- paste0(RES_SIM_DIR,"Kemmerer_2024_Lower_Bound_With_Data_Center_Simulation.csv")
|
|
||||||
NEW_RES_FILE <- !file.exists(SIM_RES_FILE)
|
|
||||||
OPERATOR_LIN_MIGRATION <- OPERATORS %>% pull("Operator_Emp_Migrated")
|
|
||||||
CONSTRUCTION_LIN_MIGRATION <- CONSTRUCTION %>% pull("Construction_Emp_Migrated")
|
|
||||||
|
|
||||||
for(i in 1:N_RUNS){
|
|
||||||
# MIGRATION_MATRIX <- simulate(nsim=BATCH_SIZE,MIGRATION_ARIMA,n=YEARS_AHEAD)
|
|
||||||
MIGRATION_MATRIX <- do.call(cbind, mclapply(1:BATCH_SIZE,function(x)(as.vector(simulate(nsim=YEARS_AHEAD,MIGRATION_ARIMA) )),mc.cores = detectCores()-1))
|
|
||||||
# rownames(MIGRATION_MATRIX) <- ST_YEAR:(ST_YEAR+YEARS_AHEAD-1)
|
|
||||||
# colnames(MIGRATION_MATRIX) <- 1:BATCH_SIZE
|
|
||||||
#SINGLE_SIM(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA,OPERATOR_LIN_MIGRATION,CONSTRUCTION_LIN_MIGRATION,INDUCED_MIGRATION_MULTIPLIERS)
|
|
||||||
try(RES <- do.call(rbind,mclapply(1:BATCH_SIZE,function(x){SINGLE_SIM(DEMO,BIRTH_DATA,ST_YEAR,YEARS_AHEAD,MIGRATION_ARIMA,OPERATOR_LIN_MIGRATION,CONSTRUCTION_LIN_MIGRATION,INDUCED_MIGRATION_MULTIPLIERS)},mc.cores=NCORES)))
|
|
||||||
if(exists("RES")){
|
|
||||||
RES <- as.data.frame(RES)
|
|
||||||
RES[,-1] <- as.numeric(as.matrix(RES[,-1]))
|
|
||||||
if(NEW_RES_FILE & i==1){write_csv(RES,SIM_RES_FILE)}else {write_csv(RES,SIM_RES_FILE,col_names=FALSE,append=TRUE)}
|
|
||||||
rm(RES)
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
@ -10,62 +10,153 @@ source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Function
|
|||||||
RES<- RES %>% filter(!is.na(Year))
|
RES<- RES %>% filter(!is.na(Year))
|
||||||
RES <- RES %>% filter(!is.na(Population))
|
RES <- RES %>% filter(!is.na(Population))
|
||||||
HIST <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(County=='Lincoln') %>% mutate(Percentile="Actual Population") %>% filter(Year>=1940)
|
HIST <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(County=='Lincoln') %>% mutate(Percentile="Actual Population") %>% filter(Year>=1940)
|
||||||
######Population
|
|
||||||
####Fan New
|
MAKE_GRAPH <- function(C_DATA,COL_NUM,TITLE=NA){
|
||||||
POP_DATA <- GET_DATA(RES,3)
|
YEARS <- min(C_DATA$Year,na.rm=TRUE):max(RES$Year,na.rm=TRUE)
|
||||||
POP_PLOT <- MAKE_GRAPH(POP_DATA)
|
LEVELS <- seq(0.00,1,by=0.025)
|
||||||
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())
|
FAN_DATA <- do.call(rbind,lapply(YEARS,function(x){quantile(as.numeric(t((C_DATA %>% filter(Year==x))[,COL_NUM])),LEVELS)})) %>% as_tibble %>% mutate(Year=YEARS)
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
LEVELS <- seq(0.00,1,by=0.025)
|
||||||
POP_PLOT
|
CI_BANDS <- do.call(rbind,lapply(YEARS,function(x){quantile(as.numeric(t((C_DATA %>% filter(Year==x))[,COL_NUM])),c(0.025,0.975,0.5,0.1,0.9))})) %>% as_tibble %>% mutate(Year=YEARS)
|
||||||
|
CI_BANDS <- CI_BANDS %>% pivot_longer(!Year,names_to="Percentile",values_to="value")
|
||||||
|
CI_BANDS$Interval <- ifelse(CI_BANDS$Percentile %in% c('2.5%','97.5%'),'95%',NA)
|
||||||
|
CI_BANDS$Interval <- ifelse(CI_BANDS$Percentile %in% c('10%','90%'),'80%',CI_BANDS$Interval)
|
||||||
|
CI_BANDS$Interval <- ifelse(CI_BANDS$Percentile %in% c('50%'),'Median Prediction',CI_BANDS$Interval)
|
||||||
|
|
||||||
|
FAN_DATA <- FAN_DATA %>% pivot_longer(!Year,names_to="Percentile",values_to="value") %>% group_by(Year) %>% mutate(DIFF=c(NA,diff(value)))
|
||||||
|
ST_VAL <- as.numeric((HIST %>% filter(Year==2024))[,COL_NUM+1])
|
||||||
|
FAN_DATA <- rbind(FAN_DATA %>% filter(Year==2025) %>% mutate(Year=2024,value=ST_VAL),FAN_DATA)
|
||||||
|
GRAPH_DATA <- FAN_DATA %>% group_by(Year) %>% mutate(MIN_RANGE=lag(parse_number(Percentile)/100),MAX_RANGE=parse_number(Percentile)/100,MIN_VAL=lag(value),MAX_VAL=value) %>% filter(!is.na(DIFF))
|
||||||
|
GRAPH_DATA[GRAPH_DATA$Year==2024,'DIFF'] <- 0
|
||||||
|
|
||||||
|
return(ggplot(GRAPH_DATA %>% filter(MIN_RANGE>=0.002,MAX_RANGE<=0.998) )+geom_ribbon(aes(group=Percentile,x=Year,ymin=MIN_VAL,ymax=MAX_VAL,fill=DIFF,alpha=-DIFF))+geom_line(data=CI_BANDS %>% filter(Interval=='Median Prediction'),aes(x=Year,y=value,group=Percentile,linetype=Interval,color=Interval),linewidth=0.75)+scale_color_manual(values=c("grey80","black"),name='Median Prediction')+scale_linetype_manual(values = c("dotdash"),guide="none")+ggtitle(TITLE)+ theme_gray()+ theme(legend.position = "top",panel.grid.minor = element_blank())+scale_alpha(range = c(0, 1),guide="none")+theme(legend.text = element_blank()))
|
||||||
|
}
|
||||||
|
|
||||||
|
###Main Results
|
||||||
|
SCALE_FACTOR <- 1.25
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Main_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES,3 ,"")+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=1)+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ expand_limits( y = 0)+labs(y="Population")+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+scale_fill_gradient(high= "#132B43", low= "#56B1F7",name ="Likelhood\n(0%-100%)", trans = 'reverse')
|
||||||
dev.off()
|
dev.off()
|
||||||
|
|
||||||
#Population Summary table for the key years
|
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Main_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
KEY_YEARS <- c(2027,2030,2035,2045,2055,2065)
|
MAKE_GRAPH(RES,4 ,"")+geom_line(data=HIST %>% filter(!is.na(Births)),aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Births")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= "#132B43", low= "#56B1F7",name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
KEY_YEAR_SUMMARY <- POP_DATA %>% filter(Year %in% KEY_YEARS,Group==5) %>% select(-Group) %>% rename(CI_95_Lower=MIN,CI_95_Upper=MAX) %>% left_join(POP_DATA %>% filter(Year %in% KEY_YEARS,Group==0) %>% select(-Group) %>% select(Year,Median=MIN)) %>% select(Year,CI_95_Lower,Median,CI_95_Upper)
|
|
||||||
KEY_YEAR_SUMMARY <- round(KEY_YEAR_SUMMARY )
|
|
||||||
KEY_YEAR_SUMMARY <- t(KEY_YEAR_SUMMARY )
|
|
||||||
write.table(KEY_YEAR_SUMMARY,paste0(SAVE_RES_LOC,"Key_Year_Summary_Main_Results.csv"), sep=",",col.names=FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
BIRTH_DATA <- GET_DATA(RES,4)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
BIRTH_PLOT
|
|
||||||
dev.off()
|
dev.off()
|
||||||
|
|
||||||
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
|
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Main_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
DEATH_PLOT <- MAKE_GRAPH(DEATH_DATA)
|
MAKE_GRAPH(RES,5 ,"")+geom_line(data=HIST %>% filter(!is.na(Deaths)),aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Deaths")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= "#132B43", low= "#56B1F7",name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
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_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
DEATH_PLOT
|
|
||||||
dev.off()
|
dev.off()
|
||||||
|
|
||||||
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
|
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Main_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
MIGRATION_PLOT <- MAKE_GRAPH(MIGRATION_DATA)
|
MAKE_GRAPH(RES,6 ,"")+geom_line(data=HIST %>% filter(!is.na(Migration)),aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(-1000, 35000, by = 100))+ expand_limits( y = 0)+labs(y="Migration")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= "#132B43", low= "#56B1F7",name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
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())
|
dev.off()
|
||||||
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
###########High Estiamtes
|
||||||
MIGRATION_PLOT
|
if(!exists("SAVE_RES_LOC_HIGH")){SAVE_RES_LOC_HIGH <- "./Results/Primary_Simulation_Results/Upper_Bound_Results/"}
|
||||||
|
dir.create(SAVE_RES_LOC_HIGH, recursive = TRUE, showWarnings = FALSE)
|
||||||
|
RES_HIGH <- RES %>% filter(Growth_Rate=='HIGH')
|
||||||
|
COLOR1 <- 'forestgreen'
|
||||||
|
COLOR2 <- 'yellow'
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_HIGH,"Population_Fan_Chart_High_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_HIGH,3 ,"")+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=1)+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ expand_limits( y = 0)+labs(y="Population")+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')
|
||||||
dev.off()
|
dev.off()
|
||||||
|
|
||||||
#####Key year table
|
png(paste0(SAVE_RES_LOC_HIGH,"Birth_Fan_Chart_High_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_HIGH,4 ,"")+geom_line(data=HIST %>% filter(!is.na(Births)),aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Births")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
dev.off()
|
||||||
|
|
||||||
YEARS <- c(2027,2030,2035,2045,2055,2065)
|
png(paste0(SAVE_RES_LOC_HIGH,"Mortality_Fan_Chart_High_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
KEY_YEAR_DATA <- RES %>% filter(Year %in% YEARS)
|
MAKE_GRAPH(RES_HIGH,5 ,"")+geom_line(data=HIST %>% filter(!is.na(Deaths)),aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Deaths")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
dev.off()
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_HIGH,"Migration_Fan_Chart_High_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_HIGH,6 ,"")+geom_line(data=HIST %>% filter(!is.na(Migration)),aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(-1000, 35000, by = 100))+ expand_limits( y = 0)+labs(y="Migration")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
dev.off()
|
||||||
|
###########Low Estiamtes
|
||||||
|
if(!exists("SAVE_RES_LOC_LOW")){SAVE_RES_LOC_LOW <- "./Results/Primary_Simulation_Results/Lower_Bound_Results/"}
|
||||||
|
dir.create(SAVE_RES_LOC_LOW, recursive = TRUE, showWarnings = FALSE)
|
||||||
|
RES_LOW <- RES %>% filter(Growth_Rate!='HIGH')
|
||||||
|
COLOR1 <- 'firebrick3'
|
||||||
|
COLOR2 <- 'white'
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_LOW,"Population_Fan_Chart_Low_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_LOW,3 ,"")+geom_line(data=HIST,aes(x=Year,y=Population),color='black',linewidth=1)+ scale_y_continuous(breaks = seq(0, 35000, by = 500))+ expand_limits( y = 0)+labs(y="Population")+ scale_x_continuous(breaks = c(seq(1940, 2060, by = 10),2065))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')
|
||||||
|
dev.off()
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_LOW,"Birth_Fan_Chart_Low_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_LOW,4 ,"")+geom_line(data=HIST %>% filter(!is.na(Births)),aes(x=Year,y=Births),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Births")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
dev.off()
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_LOW,"Mortality_Fan_Chart_Low_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_LOW,5 ,"")+geom_line(data=HIST %>% filter(!is.na(Deaths)),aes(x=Year,y=Deaths),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(0, 35000, by = 10))+ expand_limits( y = 0)+labs(y="Deaths")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
|
||||||
|
dev.off()
|
||||||
|
|
||||||
|
png(paste0(SAVE_RES_LOC_LOW,"Migration_Fan_Chart_Low_Growth_Results.png"), width = 12*SCALE_FACTOR, height = 8*SCALE_FACTOR, units = "in", res = 600)
|
||||||
|
MAKE_GRAPH(RES_LOW,6 ,"")+geom_line(data=HIST %>% filter(!is.na(Migration)),aes(x=Year,y=Migration),color='black',linewidth=0.75)+ scale_y_continuous(breaks = seq(-1000, 35000, by = 100))+ expand_limits( y = 0)+labs(y="Migration")+ scale_x_continuous(breaks = c(2009,seq(2015, 2065, by = 5)))+scale_fill_gradient(high= COLOR1, low= COLOR2,name ="Likelhood\n(0%-100%)", trans = 'reverse')+theme(legend.position = "none")
|
||||||
|
dev.off()
|
||||||
|
|
||||||
|
################################# Key Year Summaries
|
||||||
|
KEY_YEARS_OF_STUDY <- c(2027,2030,2035,2045,2055,2065)
|
||||||
|
CI_BANDS <- do.call(rbind,lapply(KEY_YEARS_OF_STUDY ,function(x){quantile(as.numeric(t((RES%>% filter(Year==x))[,3])),c(0.025,0.975,0.5))})) %>% as_tibble %>% mutate(Year=KEY_YEARS_OF_STUDY)
|
||||||
|
CI_BANDS <- CI_BANDS %>% pivot_longer(!Year,names_to="Percentile",values_to="value")
|
||||||
|
CI_BANDS$Interval <- ifelse(CI_BANDS$Percentile %in% c('2.5%','97.5%'),'95%',NA)
|
||||||
|
CI_BANDS$Interval <- ifelse(CI_BANDS$Percentile %in% c('50%'),'Median',CI_BANDS$Interval)
|
||||||
|
KEY_YEAR_SUMMARY_TBL <- CI_BANDS %>% group_by(Year) %>% summarize(CI_95_Lower=min(value),Median=median(value),CI_95_Upper=max(value))
|
||||||
|
write_csv(round(KEY_YEAR_SUMMARY_TBL,0),paste0(SAVE_RES_LOC,"Key_Year_Summary_Main_Results.csv"))
|
||||||
|
|
||||||
|
|
||||||
|
######High Results
|
||||||
|
CI_BANDS_HIGH <- do.call(rbind,lapply(KEY_YEARS_OF_STUDY ,function(x){quantile(as.numeric(t((RES_HIGH%>% filter(Year==x))[,3])),c(0.025,0.975,0.5))})) %>% as_tibble %>% mutate(Year=KEY_YEARS_OF_STUDY)
|
||||||
|
CI_BANDS_HIGH <- CI_BANDS_HIGH %>% pivot_longer(!Year,names_to="Percentile",values_to="value")
|
||||||
|
CI_BANDS_HIGH$Interval <- ifelse(CI_BANDS_HIGH$Percentile %in% c('2.5%','97.5%'),'95%',NA)
|
||||||
|
CI_BANDS_HIGH$Interval <- ifelse(CI_BANDS_HIGH$Percentile %in% c('50%'),'Median',CI_BANDS_HIGH$Interval)
|
||||||
|
KEY_YEAR_SUMMARY_TBL_HIGH <- CI_BANDS_HIGH %>% group_by(Year) %>% summarize(CI_95_Lower=min(value),Median=median(value),CI_95_Upper=max(value))
|
||||||
|
KEY_YEAR_SUMMARY_TBL_HIGH
|
||||||
|
write_csv(round(KEY_YEAR_SUMMARY_TBL_HIGH,0),paste0(SAVE_RES_LOC_HIGH,"Key_Year_Summary_Upper_Bound.csv"))
|
||||||
|
|
||||||
|
|
||||||
|
######Low Results
|
||||||
|
CI_BANDS_LOW <- do.call(rbind,lapply(KEY_YEARS_OF_STUDY ,function(x){quantile(as.numeric(t((RES_LOW%>% filter(Year==x))[,3])),c(0.025,0.975,0.5))})) %>% as_tibble %>% mutate(Year=KEY_YEARS_OF_STUDY)
|
||||||
|
CI_BANDS_LOW <- CI_BANDS_LOW %>% pivot_longer(!Year,names_to="Percentile",values_to="value")
|
||||||
|
CI_BANDS_LOW$Interval <- ifelse(CI_BANDS_LOW$Percentile %in% c('2.5%','97.5%'),'95%',NA)
|
||||||
|
CI_BANDS_LOW$Interval <- ifelse(CI_BANDS_LOW$Percentile %in% c('50%'),'Median',CI_BANDS_LOW$Interval)
|
||||||
|
KEY_YEAR_SUMMARY_TBL_LOW <- CI_BANDS_LOW %>% group_by(Year) %>% summarize(CI_95_Lower=min(value),Median=median(value),CI_95_Upper=max(value))
|
||||||
|
write_csv(round(KEY_YEAR_SUMMARY_TBL_LOW,0),paste0(SAVE_RES_LOC_LOW,"Key_Year_Summary_Lower_Bound.csv"))
|
||||||
|
################################# Histograms
|
||||||
|
KEY_YEAR_DATA <- RES %>% filter(Year %in% KEY_YEARS_OF_STUDY )
|
||||||
AVG_VALUES <- KEY_YEAR_DATA %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
AVG_VALUES <- KEY_YEAR_DATA %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
||||||
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_YEAR_DATA, 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.`), linewidth= 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_YEAR_DATA, 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.`), linewidth= 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_Main_Results.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()
|
||||||
#rm(KEY_YEARS)
|
####Upper
|
||||||
POP_LEVELS <- seq(2000,6000,100)
|
KEY_YEAR_DATA <- RES_HIGH %>% filter(Year %in% KEY_YEARS_OF_STUDY )
|
||||||
YEARS
|
AVG_VALUES <- KEY_YEAR_DATA %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
||||||
|
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_YEAR_DATA, 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_HIGH,"Population_Histogram_Upper_Bound.png"), width = 8, height = 12, units = "in", res = 600)
|
||||||
|
HISTOGRAM
|
||||||
|
dev.off()
|
||||||
|
####Lower
|
||||||
|
KEY_YEAR_DATA <- RES_LOW %>% filter(Year %in% KEY_YEARS_OF_STUDY )
|
||||||
|
AVG_VALUES <- KEY_YEAR_DATA %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
||||||
|
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_YEAR_DATA, 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_LOW,"Population_Histogram_Lower_Bound.png"), width = 8, height = 12, units = "in", res = 600)
|
||||||
|
HISTOGRAM
|
||||||
|
dev.off()
|
||||||
|
############################Capacity Tables
|
||||||
|
MAKE_GT <- function(DATA,POP_LEVELS=seq(2000,6000,100)){
|
||||||
|
YEARS <- c(2027,2030,2035,2045,2055,2065)
|
||||||
if(exists("KEY_YEARS")){rm(KEY_YEARS)}
|
if(exists("KEY_YEARS")){rm(KEY_YEARS)}
|
||||||
for(i in YEARS ){
|
for(i in YEARS ){
|
||||||
CURRENT_YEAR_DATA <- RES %>% filter(Year==i ) %>% pull(Population)
|
KEY <- DATA%>% filter(Year==i ) %>% pull(Population)
|
||||||
ECDF <- ecdf(CURRENT_YEAR_DATA)
|
ECDF <- ecdf(KEY)
|
||||||
ECDF_VALUES <- ECDF(POP_LEVELS)
|
ECDF_VALUES <- ECDF(POP_LEVELS)
|
||||||
if(!exists("KEY_YEARS")){KEY_YEARS<- ECDF_VALUES} else{KEY_YEARS<- cbind(KEY_YEARS,ECDF_VALUES)}
|
if(!exists("KEY_YEARS")){KEY_YEARS<- ECDF_VALUES} else{KEY_YEARS<- cbind(KEY_YEARS,ECDF_VALUES)}
|
||||||
|
|
||||||
@ -77,6 +168,17 @@ 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_Main_Results.html")
|
return(Capacity_Risk)
|
||||||
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 99mm --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")
|
}
|
||||||
|
TBL_MAIN <- MAKE_GT(RES)
|
||||||
|
TBL_HIGH <- MAKE_GT(RES_HIGH)
|
||||||
|
TBL_LOW <- MAKE_GT(RES_LOW)
|
||||||
|
gtsave( data = TBL_MAIN, filename = "./Results/Primary_Simulation_Results/Main_Results/Capacity_Table_Main_Results.html")
|
||||||
|
gtsave( data = TBL_HIGH, filename = "./Results/Primary_Simulation_Results/Upper_Bound_Results/Capacity_Table_Upper_Bound.html")
|
||||||
|
gtsave( data = TBL_LOW, 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 99mm --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")
|
||||||
|
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 101mm --page-height 331mm ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.html ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.pdf")
|
||||||
|
system("wkhtmltopdf --disable-smart-shrinking --no-stop-slow-scripts --enable-local-file-access --page-width 96mm --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")
|
||||||
|
|
||||||
|
|||||||
@ -1,81 +0,0 @@
|
|||||||
library(tidyverse)
|
|
||||||
library(gt) #For nice color coded capacity limits table.
|
|
||||||
source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Functions created to make nice graphs
|
|
||||||
if(!exists("SAVE_RES_LOC")){SAVE_RES_LOC <- "./Results/Primary_Simulation_Results/Upper_Bound_Results/"}
|
|
||||||
dir.create(SAVE_RES_LOC, recursive = TRUE, showWarnings = FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
###Process the simulations and save the main percentile results by year
|
|
||||||
RES <- read_csv("Results/Simulations/Kemmerer_2024_Upper_Bound_With_Data_Center_Simulation.csv")
|
|
||||||
RES[,"Year"] <- RES[,"Year"]
|
|
||||||
RES<- RES %>% filter(!is.na(Year))
|
|
||||||
RES <- RES %>% filter(!is.na(Population))
|
|
||||||
HIST <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(County=='Lincoln') %>% mutate(Percentile="Actual Population") %>% filter(Year>=1940)
|
|
||||||
######Population
|
|
||||||
####Fan New
|
|
||||||
POP_DATA <- GET_DATA(RES,3)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
POP_PLOT
|
|
||||||
dev.off()
|
|
||||||
#Population Summary table for the key years
|
|
||||||
KEY_YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
KEY_YEAR_SUMMARY <- POP_DATA %>% filter(Year %in% KEY_YEARS,Group==5) %>% select(-Group) %>% rename(CI_95_Lower=MIN,CI_95_Upper=MAX) %>% left_join(POP_DATA %>% filter(Year %in% KEY_YEARS,Group==0) %>% select(-Group) %>% select(Year,Median=MIN)) %>% select(Year,CI_95_Lower,Median,CI_95_Upper)
|
|
||||||
KEY_YEAR_SUMMARY <- round(KEY_YEAR_SUMMARY )
|
|
||||||
KEY_YEAR_SUMMARY <- t(KEY_YEAR_SUMMARY )
|
|
||||||
write.table(KEY_YEAR_SUMMARY,paste0(SAVE_RES_LOC,"Key_Year_Summary_Upper_Bound.csv"), sep=",",col.names=FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
BIRTH_DATA <- GET_DATA(RES,4)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
BIRTH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
DEATH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Upper_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
MIGRATION_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#####Key year table
|
|
||||||
KEY <- RES %>% filter(Year %in% c(2027,2030,2035,2045,2055,2065))
|
|
||||||
AVG_VALUES <- KEY %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
|
||||||
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))
|
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Histogram_Upper_Bound.png"), width = 8, height = 12, units = "in", res = 600)
|
|
||||||
HISTOGRAM
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#rm(KEY_YEARS)
|
|
||||||
POP_LEVELS <- seq(2000,6000,100)
|
|
||||||
YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
if(exists("KEY_YEARS")){rm(KEY_YEARS)}
|
|
||||||
for(i in YEARS ){
|
|
||||||
KEY <- RES %>% filter(Year==i ) %>% pull(Population)
|
|
||||||
ECDF <- ecdf(KEY)
|
|
||||||
ECDF_VALUES <- ECDF(POP_LEVELS)
|
|
||||||
if(!exists("KEY_YEARS")){KEY_YEARS<- ECDF_VALUES} else{KEY_YEARS<- cbind(KEY_YEARS,ECDF_VALUES)}
|
|
||||||
|
|
||||||
}
|
|
||||||
colnames(KEY_YEARS) <- YEARS
|
|
||||||
rownames(KEY_YEARS) <- POP_LEVELS
|
|
||||||
PLOT_GREEN <- "forestgreen"
|
|
||||||
PLOT_YELLOW <- "yellow"
|
|
||||||
PLOT_RED <- "red"
|
|
||||||
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"))
|
|
||||||
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 96mm --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")
|
|
||||||
|
|
||||||
@ -1,82 +0,0 @@
|
|||||||
library(tidyverse)
|
|
||||||
library(gt) #For nice color coded capacity limits table.
|
|
||||||
source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Functions created to make nice graphs
|
|
||||||
if(!exists("SAVE_RES_LOC")){SAVE_RES_LOC <- "./Results/Primary_Simulation_Results/Lower_Bound_Results/"}
|
|
||||||
dir.create(SAVE_RES_LOC, recursive = TRUE, showWarnings = FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
###Process the simulations and save the main percentile results by year
|
|
||||||
RES <- read_csv("Results/Simulations/Kemmerer_2024_Lower_Bound_With_Data_Center_Simulation.csv")
|
|
||||||
RES[,"Year"] <- RES[,"Year"]
|
|
||||||
RES<- RES %>% filter(!is.na(Year))
|
|
||||||
RES <- RES %>% filter(!is.na(Population))
|
|
||||||
HIST <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(County=='Lincoln') %>% mutate(Percentile="Actual Population") %>% filter(Year>=1940)
|
|
||||||
######Population
|
|
||||||
####Fan New
|
|
||||||
POP_DATA <- GET_DATA(RES,3)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
POP_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#Population Summary table for the key years
|
|
||||||
KEY_YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
KEY_YEAR_SUMMARY <- POP_DATA %>% filter(Year %in% KEY_YEARS,Group==5) %>% select(-Group) %>% rename(CI_95_Lower=MIN,CI_95_Upper=MAX) %>% left_join(POP_DATA %>% filter(Year %in% KEY_YEARS,Group==0) %>% select(-Group) %>% select(Year,Median=MIN)) %>% select(Year,CI_95_Lower,Median,CI_95_Upper)
|
|
||||||
KEY_YEAR_SUMMARY <- round(KEY_YEAR_SUMMARY )
|
|
||||||
KEY_YEAR_SUMMARY <- t(KEY_YEAR_SUMMARY )
|
|
||||||
write.table(KEY_YEAR_SUMMARY,paste0(SAVE_RES_LOC,"Key_Year_Summary_Lower_Bound.csv"), sep=",",col.names=FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
BIRTH_DATA <- GET_DATA(RES,4)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
BIRTH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
DEATH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Lower_Bound.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
MIGRATION_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#####Key year table
|
|
||||||
KEY <- RES %>% filter(Year %in% c(2027,2030,2035,2045,2055,2065))
|
|
||||||
AVG_VALUES <- KEY %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
|
||||||
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))
|
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Histogram_Lower_Bound.png"), width = 8, height = 12, units = "in", res = 600)
|
|
||||||
HISTOGRAM
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#rm(KEY_YEARS)
|
|
||||||
POP_LEVELS <- seq(2000,6000,100)
|
|
||||||
YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
if(exists("KEY_YEARS")){rm(KEY_YEARS)}
|
|
||||||
for(i in YEARS ){
|
|
||||||
KEY <- RES %>% filter(Year==i ) %>% pull(Population)
|
|
||||||
ECDF <- ecdf(KEY)
|
|
||||||
ECDF_VALUES <- ECDF(POP_LEVELS)
|
|
||||||
if(!exists("KEY_YEARS")){KEY_YEARS<- ECDF_VALUES} else{KEY_YEARS<- cbind(KEY_YEARS,ECDF_VALUES)}
|
|
||||||
|
|
||||||
}
|
|
||||||
colnames(KEY_YEARS) <- YEARS
|
|
||||||
rownames(KEY_YEARS) <- POP_LEVELS
|
|
||||||
PLOT_GREEN <- "forestgreen"
|
|
||||||
PLOT_YELLOW <- "yellow"
|
|
||||||
PLOT_RED <- "red"
|
|
||||||
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"))
|
|
||||||
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 101mm --page-height 331mm ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.html ./Results/Primary_Simulation_Results/Lower_Bound_Results/Capacity_Table_Lower_Bound.pdf")
|
|
||||||
|
|
||||||
@ -1,4 +0,0 @@
|
|||||||
Rscript 2A_2016_Result_Analysis_2016_and_Historic_Trend.r
|
|
||||||
Rscript 2B_Result_Analysis.r
|
|
||||||
Rscript 2C_Upper_Bound_Result_Analysis.r
|
|
||||||
Rscript 2D_Lower_Bound_Result_Analysis.r
|
|
||||||
@ -1,20 +1,9 @@
|
|||||||
#Run all simulations as needed. Comment out to skip any. All but the primary results have 10^5 simulations
|
#Run all simulations as needed. Comment out to skip any. All but the primary results have 10^5 simulations
|
||||||
echo "Starting all model Simulations. This will take a while!!"
|
echo "Starting all model Simulations. This will take a while!!"
|
||||||
|
|
||||||
start_time=$(date +%s)
|
|
||||||
Rscript 1A_Run_Full_Simulation_2016.r
|
|
||||||
echo "Pre-2016 data simulations for benchmark complete! 100k simulations total"
|
|
||||||
end_time=$(date +%s)
|
|
||||||
elapsed_seconds=$((end_time - start_time))
|
|
||||||
hours=$((elapsed_seconds / 3600))
|
|
||||||
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
|
||||||
seconds=$(( elapsed_seconds % 60 ))
|
|
||||||
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
|
||||||
|
|
||||||
|
|
||||||
#start_time=$(date +%s)
|
#start_time=$(date +%s)
|
||||||
#Rscript 1C_Run_Simulation_Upper_Bound.r
|
#Rscript 1A_Run_Full_Simulation_2016.r
|
||||||
#echo "Upper bound migration with county average migration rates complete! 100k simulations total"
|
#echo "Pre-2016 data simulations for benchmark complete! 100k simulations total"
|
||||||
#end_time=$(date +%s)
|
#end_time=$(date +%s)
|
||||||
#elapsed_seconds=$((end_time - start_time))
|
#elapsed_seconds=$((end_time - start_time))
|
||||||
#hours=$((elapsed_seconds / 3600))
|
#hours=$((elapsed_seconds / 3600))
|
||||||
@ -23,18 +12,6 @@ printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$min
|
|||||||
#printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
#printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
|
||||||
|
|
||||||
start_time=$(date +%s)
|
|
||||||
Rscript 1D_Run_Simulation_Lower_Bound.r
|
|
||||||
echo "Lower bound migration with Kemmerere average migration rates complete! 100k simulations total"
|
|
||||||
end_time=$(date +%s)
|
|
||||||
elapsed_seconds=$((end_time - start_time))
|
|
||||||
hours=$((elapsed_seconds / 3600))
|
|
||||||
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
|
||||||
seconds=$(( elapsed_seconds % 60 ))
|
|
||||||
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
start_time=$(date +%s)
|
start_time=$(date +%s)
|
||||||
Rscript 1B_Run_Full_Simulation.r
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
echo "Main results with variable migration rates complete! 1 million simulations total"
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
@ -46,13 +23,64 @@ seconds=$(( elapsed_seconds % 60 ))
|
|||||||
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
|
||||||
start_time=$(date +%s)
|
start_time=$(date +%s)
|
||||||
Rscript 1D_Run_Simulation_Lower_Bound.r
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
Rscript 1D_Run_Simulation_Lower_Bound.r
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
Rscript 1A_Run_Full_Simulation_2016.r
|
end_time=$(date +%s)
|
||||||
Rscript 1A_Run_Full_Simulation_2016.r
|
elapsed_seconds=$((end_time - start_time))
|
||||||
Rscript 1D_Run_Simulation_Lower_Bound.r
|
hours=$((elapsed_seconds / 3600))
|
||||||
Rscript 1A_Run_Full_Simulation_2016.r
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
echo "Extra simulations complete! 600k simulations total"
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
|
end_time=$(date +%s)
|
||||||
|
elapsed_seconds=$((end_time - start_time))
|
||||||
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
|
end_time=$(date +%s)
|
||||||
|
elapsed_seconds=$((end_time - start_time))
|
||||||
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
|
end_time=$(date +%s)
|
||||||
|
elapsed_seconds=$((end_time - start_time))
|
||||||
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
|
end_time=$(date +%s)
|
||||||
|
elapsed_seconds=$((end_time - start_time))
|
||||||
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
|
end_time=$(date +%s)
|
||||||
|
elapsed_seconds=$((end_time - start_time))
|
||||||
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
minutes=$(( (elapsed_seconds % 3600) / 60 ))
|
||||||
|
seconds=$(( elapsed_seconds % 60 ))
|
||||||
|
printf "Execution time: %02d hours, %02d minutes, %02d seconds\n" "$hours" "$minutes" "$seconds"
|
||||||
|
start_time=$(date +%s)
|
||||||
|
Rscript 1B_Run_Full_Simulation.r
|
||||||
|
echo "Main results with variable migration rates complete! 1 million simulations total"
|
||||||
end_time=$(date +%s)
|
end_time=$(date +%s)
|
||||||
elapsed_seconds=$((end_time - start_time))
|
elapsed_seconds=$((end_time - start_time))
|
||||||
hours=$((elapsed_seconds / 3600))
|
hours=$((elapsed_seconds / 3600))
|
||||||
|
|||||||
124
TESTING.r
124
TESTING.r
@ -1,124 +0,0 @@
|
|||||||
library(tidyverse)
|
|
||||||
library(gt) #For nice color coded capacity limits table.
|
|
||||||
source("Scripts/Load_Custom_Functions/Fan_Chart_Creation_Functions.r") #Functions created to make nice graphs
|
|
||||||
if(!exists("SAVE_RES_LOC")){SAVE_RES_LOC <- "./Results/Primary_Simulation_Results/Main_Results/"}
|
|
||||||
dir.create(SAVE_RES_LOC, recursive = TRUE, showWarnings = FALSE)
|
|
||||||
|
|
||||||
###Process the simulations and save the main percentile results by year
|
|
||||||
RES <- read_csv("Results/Simulations/Kemmerer_2024_With_Data_Center_Simulation.csv")
|
|
||||||
RES[,"Year"] <- RES[,"Year"]
|
|
||||||
RES<- RES %>% filter(!is.na(Year))
|
|
||||||
RES <- RES %>% filter(!is.na(Population))
|
|
||||||
HIST <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(County=='Lincoln') %>% mutate(Percentile="Actual Population") %>% filter(Year>=1940)
|
|
||||||
######Population
|
|
||||||
####Fan New
|
|
||||||
#POP_DATA <- GET_DATA(RES,3)
|
|
||||||
#POP_PLOT <- MAKE_GRAPH(POP_DATA)
|
|
||||||
########TEST
|
|
||||||
SIM_START=2025
|
|
||||||
LAST_HISTORIC <- SIM_START-1
|
|
||||||
YEARS <- min(RES$Year,na.rm=TRUE):max(RES$Year,na.rm=TRUE)
|
|
||||||
LEVELS <- seq(0.00,1,by=0.005)
|
|
||||||
GROUPS <- floor(length(LEVELS)/2)
|
|
||||||
COL_NUM <-3
|
|
||||||
RES %>% tail
|
|
||||||
#C_DATA<- RES %>% filter(Growth_Rate=='HIGH')
|
|
||||||
#C_DATA <- RES %>% filter(Growth_Rate!='HIGH')
|
|
||||||
C_DATA <- RES
|
|
||||||
|
|
||||||
nrow(RES)
|
|
||||||
FAN_DATA <- do.call(rbind,lapply(YEARS,function(x){quantile(as.numeric(t((C_DATA %>% filter(Year==x))[,COL_NUM])),LEVELS)})) %>% as_tibble %>% mutate(Year=YEARS)
|
|
||||||
FAN_DATA <- FAN_DATA %>% pivot_longer(!Year,names_to="Percentile",values_to="Population") %>% group_by(Year) %>% mutate(DIFF=c(NA,diff(Population)))
|
|
||||||
GRAPH_DATA <- FAN_DATA %>% group_by(Year) %>% mutate(MIN_RANGE=lag(parse_number(Percentile)/100),MAX_RANGE=parse_number(Percentile)/100,MIN_POP=lag(Population),MAX_POP=Population) %>% filter(!is.na(DIFF))
|
|
||||||
GRAPH_DATA <- GRAPH_DATA %>% mutate(MAX_POP=ifelse(MAX_RANGE!=1,MAX_POP-0.001,MAX_POP))
|
|
||||||
CI_80 <- GRAPH_DATA%>% filter(Percentile %in%c('10.0%','90.0%')) %>% group_by(Year) %>% summarize(MIN_POP=min(MIN_POP),MAX_POP=max(MAX_POP),Interval='80%')
|
|
||||||
CI_95 <- GRAPH_DATA%>% filter(Percentile %in%c('2.5%','97.5%')) %>% group_by(Year) %>% summarize(MIN_POP=min(MIN_POP),MAX_POP=max(MAX_POP),Interval='95%')
|
|
||||||
MEDIAN <- GRAPH_DATA%>% filter(Percentile %in%c('50.0%'))%>% group_by(Year) %>% summarize(MIN_POP=min(MIN_POP),MAX_POP=max(MAX_POP),Interval='Median')
|
|
||||||
RANGE_DATA <- rbind(MEDIAN ,CI_80,CI_95)
|
|
||||||
ggplot(GRAPH_DATA %>% filter(MIN_RANGE>=0.015,MAX_RANGE<=0.985) )+geom_ribbon(aes(group=Percentile,x=Year,ymin=MIN_POP,ymax=MAX_POP,alpha=-DIFF),fill='cadetblue')+geom_line(data=GRAPH_DATA %>% filter(Percentile=='50%'),aes(x=Year,y=MIN_POP))+geom_line(data=RANGE_DATA,aes(color=Interval,linetype=Interval,x=Year,y=MIN_POP))+geom_line(data=RANGE_DATA,aes(color=Interval,linetype=Interval,x=Year,y=MAX_POP))+scale_color_manual(values=c("grey50","grey80","black"))+scale_linetype_manual(values = c("solid","solid","dotdash"))+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())+scale_alpha(range = c(0, 1),guide="none")
|
|
||||||
C_DATA
|
|
||||||
|
|
||||||
geom_
|
|
||||||
|
|
||||||
RANGE_DATA
|
|
||||||
|
|
||||||
|
|
||||||
QUANT <- quantile(as.numeric(t((RES %>% filter(Year==2025))[,3])),LEVELS) %>% as.numeric
|
|
||||||
RANGE <- QUANT %>% diff
|
|
||||||
RANGE
|
|
||||||
RANGE <- RANGE[-1]
|
|
||||||
RANGE <- RANGE[-length(RANGE)]
|
|
||||||
RANGE <- 1-RANGE/max(RANGE)
|
|
||||||
RANGE
|
|
||||||
scale(RANGE)
|
|
||||||
FAN_DATA <- do.call(rbind,lapply(YEARS,function(x){quantile(as.numeric(t((RES %>% filter(Year==x))[,COL_NUM])),LEVELS)})) %>% as_tibble %>% mutate(Year=YEARS)
|
|
||||||
FAN_DATA <- rbind(FAN_DATA[1,],FAN_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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Population_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
POP_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#Population Summary table for the key years
|
|
||||||
KEY_YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
KEY_YEAR_SUMMARY <- POP_DATA %>% filter(Year %in% KEY_YEARS,Group==5) %>% select(-Group) %>% rename(CI_95_Lower=MIN,CI_95_Upper=MAX) %>% left_join(POP_DATA %>% filter(Year %in% KEY_YEARS,Group==0) %>% select(-Group) %>% select(Year,Median=MIN)) %>% select(Year,CI_95_Lower,Median,CI_95_Upper)
|
|
||||||
KEY_YEAR_SUMMARY <- round(KEY_YEAR_SUMMARY )
|
|
||||||
KEY_YEAR_SUMMARY <- t(KEY_YEAR_SUMMARY )
|
|
||||||
write.table(KEY_YEAR_SUMMARY,paste0(SAVE_RES_LOC,"Key_Year_Summary_Main_Results.csv"), sep=",",col.names=FALSE)
|
|
||||||
|
|
||||||
|
|
||||||
BIRTH_DATA <- GET_DATA(RES,4)
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Birth_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
BIRTH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
DEATH_DATA <- GET_DATA(RES,5) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Mortality_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
DEATH_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
MIGRATION_DATA <- GET_DATA(RES,6) %>% filter(!is.na(MIN))
|
|
||||||
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())
|
|
||||||
png(paste0(SAVE_RES_LOC,"Migration_Fan_Chart_Main_Results.png"), width = 12, height = 8, units = "in", res = 600)
|
|
||||||
MIGRATION_PLOT
|
|
||||||
dev.off()
|
|
||||||
|
|
||||||
#####Key year table
|
|
||||||
|
|
||||||
YEARS <- c(2027,2030,2035,2045,2055,2065)
|
|
||||||
KEY_YEAR_DATA <- RES %>% filter(Year %in% YEARS)
|
|
||||||
AVG_VALUES <- KEY_YEAR_DATA %>% group_by(Year) %>% summarize(MED=median(Population),MEAN=mean(Population))
|
|
||||||
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_YEAR_DATA, 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.`), linewidth= 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_Main_Results.png"), width = 8, height = 12, units = "in", res = 600)
|
|
||||||
HISTOGRAM
|
|
||||||
dev.off()
|
|
||||||
#rm(KEY_YEARS)
|
|
||||||
POP_LEVELS <- seq(2000,6000,100)
|
|
||||||
YEARS
|
|
||||||
if(exists("KEY_YEARS")){rm(KEY_YEARS)}
|
|
||||||
for(i in YEARS ){
|
|
||||||
CURRENT_YEAR_DATA <- RES %>% filter(Year==i ) %>% pull(Population)
|
|
||||||
ECDF <- ecdf(CURRENT_YEAR_DATA)
|
|
||||||
ECDF_VALUES <- ECDF(POP_LEVELS)
|
|
||||||
if(!exists("KEY_YEARS")){KEY_YEARS<- ECDF_VALUES} else{KEY_YEARS<- cbind(KEY_YEARS,ECDF_VALUES)}
|
|
||||||
|
|
||||||
}
|
|
||||||
colnames(KEY_YEARS) <- YEARS
|
|
||||||
rownames(KEY_YEARS) <- POP_LEVELS
|
|
||||||
PLOT_GREEN <- "forestgreen"
|
|
||||||
PLOT_YELLOW <- "yellow"
|
|
||||||
PLOT_RED <- "red"
|
|
||||||
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"))
|
|
||||||
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 99mm --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")
|
|
||||||
|
|
||||||
Loading…
x
Reference in New Issue
Block a user