Demographic split Kem/Lin and start sim files made

.gitignore

@@ -1,6 +1,8 @@
 # ---> R
 # 
 *.png
+*.csv
+
 Results/
 #Don't save any major data files on the server, can be regenerated after pulling
 *.Rds

1_Run_Full_Simulation.r

@@ -31,6 +31,8 @@ if(RERUN_MIGRATION_SIMULATION ){source("Migration_Regression.r")}
 START_DEM_DATA <- readRDS("Data/Cleaned_Data/Lincoln_Demographic_Data.Rds") %>% group_by(County) %>% filter(Year==2023) %>% ungroup %>% select(-County)
 MORTALITY_SIMULATION <- readRDS("./Data/Simulated_Data_Sets/MORTALITY_MONTE_CARLO.Rds") #Load the Mortality simulation to speed up simulation
 MIGRATION_ARIMA_SIMULATION <- readRDS("./Data/Simulated_Data_Sets/Migration_ARIMA.Rds") #Load the Migration simulation to speed up simulation
+
+#####################!!!!!!!!!!!!!!!!!!!Working on pulling in data from the Data/Cleaned_Data/Intiate_Simulation/ directory which stores a starting point for all groups. Make data much more clean
 if(KEMMER_SIM){
 	LN_POP_ST <- FIRST_PREDICT_YEAR_POPULATION_DATA$Population #Population of Lincoln County
  	START_DEM_DATA <- readRDS("Data/Cleaned_Data/Kemmerer_Demographic_Data.Rds") %>% select(-County) %>% mutate(County='Lincoln')

Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Demographic_Data.csv

@@ -1,87 +1,87 @@
 County,Year,Age,Num_Male,Num_Female
-Kemmerer,2024,0,10.464965521092157,18.53827755476956
+Kemmerer,2024,0,10,19
-Kemmerer,2024,1,10.73329797035093,26.12211837262983
+Kemmerer,2024,1,11,26
-Kemmerer,2024,2,9.838856472821687,22.330197963699696
+Kemmerer,2024,2,10,22
-Kemmerer,2024,3,11.717183617633099,26.3327806175704
+Kemmerer,2024,3,12,26
-Kemmerer,2024,4,10.464965521092157,24.015495923224204
+Kemmerer,2024,4,10,24
-Kemmerer,2024,5,15.460982984335295,16.925040008171884
+Kemmerer,2024,5,15,17
-Kemmerer,2024,6,19.09886133359066,18.773993958644443
+Kemmerer,2024,6,19,19
-Kemmerer,2024,7,20.78787628145922,22.045220178711276
+Kemmerer,2024,7,21,22
-Kemmerer,2024,8,17.409846385722098,19.34290286648215
+Kemmerer,2024,8,17,19
-Kemmerer,2024,9,21.17764896173658,20.05403900127929
+Kemmerer,2024,9,21,20
-Kemmerer,2024,10,23.313248886019743,19.837665883519023
+Kemmerer,2024,10,23,20
-Kemmerer,2024,11,24.63286674749256,19.692865402617425
+Kemmerer,2024,11,25,20
-Kemmerer,2024,12,25.0727393679835,18.534461555404636
+Kemmerer,2024,12,25,19
-Kemmerer,2024,13,24.19299412700162,23.023276463354193
+Kemmerer,2024,13,24,23
-Kemmerer,2024,14,26.53898143628663,23.74727886786219
+Kemmerer,2024,14,27,24
-Kemmerer,2024,15,13.763908906585888,13.325834953286826
+Kemmerer,2024,15,14,13
-Kemmerer,2024,16,14.400390243306624,12.585510789215336
+Kemmerer,2024,16,14,13
-Kemmerer,2024,17,15.116431747117451,11.919219041550994
+Kemmerer,2024,17,15,12
-Kemmerer,2024,18,8.11409091515564,8.11283185840708
+Kemmerer,2024,18,8,8
-Kemmerer,2024,19,6.633417390492201,5.672882427307205
+Kemmerer,2024,19,7,6
-Kemmerer,2024,20,8.976744186046512,27.571428571428573
+Kemmerer,2024,20,9,28
-Kemmerer,2024,21,0,6.411960132890365
+Kemmerer,2024,21,0,6
-Kemmerer,2024,22,10.007317017094115,16.00986295681063
+Kemmerer,2024,22,10,16
-Kemmerer,2024,23,9.285139500396603,13.795732973421927
+Kemmerer,2024,23,9,14
-Kemmerer,2024,24,10.523158100449484,13.795732973421927
+Kemmerer,2024,24,11,14
-Kemmerer,2024,25,14.229527197897555,14.473076411960134
+Kemmerer,2024,25,14,14
-Kemmerer,2024,26,12.94653704071007,15.057847176079733
+Kemmerer,2024,26,13,15
-Kemmerer,2024,27,13.179807978380522,13.888305647840532
+Kemmerer,2024,27,13,14
-Kemmerer,2024,28,9.214202037982844,13.74211295681063
+Kemmerer,2024,28,9,14
-Kemmerer,2024,29,12.94653704071007,15.935003322259135
+Kemmerer,2024,29,13,16
-Kemmerer,2024,30,9.841972541328104,16.16915622314293
+Kemmerer,2024,30,10,16
-Kemmerer,2024,31,10.64539887123244,16.16915622314293
+Kemmerer,2024,31,11,16
-Kemmerer,2024,32,9.339831085137893,17.360567734321886
+Kemmerer,2024,32,9,17
-Kemmerer,2024,33,10.24368570628027,17.360567734321886
+Kemmerer,2024,33,10,17
-Kemmerer,2024,34,9.942400832566145,21.10500391231288
+Kemmerer,2024,34,10,21
-Kemmerer,2024,35,23.090047712195066,13.797127159737228
+Kemmerer,2024,35,23,14
-Kemmerer,2024,36,24.414886515353803,15.316076938790872
+Kemmerer,2024,36,24,15
-Kemmerer,2024,37,21.386683536705274,16.20213097657216
+Kemmerer,2024,37,21,16
-Kemmerer,2024,38,23.2793103983606,16.835026717844507
+Kemmerer,2024,38,23,17
-Kemmerer,2024,39,29.33571635565767,16.07555182831769
+Kemmerer,2024,39,29,16
-Kemmerer,2024,40,17.783950233132593,12.477327826165036
+Kemmerer,2024,40,18,12
-Kemmerer,2024,41,17.654140377416297,12.581305558049745
+Kemmerer,2024,41,18,13
-Kemmerer,2024,42,16.615661531685927,13.413127413127413
+Kemmerer,2024,42,17,13
-Kemmerer,2024,43,18.30318965599778,15.388704318936878
+Kemmerer,2024,43,18,15
-Kemmerer,2024,44,19.73109806887704,15.388704318936878
+Kemmerer,2024,44,20,15
-Kemmerer,2024,45,9.96622215641455,21.42182039512059
+Kemmerer,2024,45,10,21
-Kemmerer,2024,46,10.86595054553531,17.354386142882504
+Kemmerer,2024,46,11,17
-Kemmerer,2024,47,10.796740669449097,16.812061575917422
+Kemmerer,2024,47,11,17
-Kemmerer,2024,48,9.96622215641455,16.405318150693617
+Kemmerer,2024,48,10,16
-Kemmerer,2024,49,8.097555502086824,16.812061575917422
+Kemmerer,2024,49,8,17
-Kemmerer,2024,50,11.910119959416715,17.094436330798903
+Kemmerer,2024,50,12,17
-Kemmerer,2024,51,12.541717229991843,18.692047202836182
+Kemmerer,2024,51,13,19
-Kemmerer,2024,52,13.443999045099172,20.928702423688375
+Kemmerer,2024,52,13,21
-Kemmerer,2024,53,12.000348140927445,20.928702423688375
+Kemmerer,2024,53,12,21
-Kemmerer,2024,54,10.37624087373426,17.57371959241009
+Kemmerer,2024,54,10,18
-Kemmerer,2024,55,27.330581312705572,17.79318936877076
+Kemmerer,2024,55,27,18
-Kemmerer,2024,56,28.04355299912398,19.075581395348838
+Kemmerer,2024,56,28,19
-Kemmerer,2024,57,24.71635179583808,19.716777408637874
+Kemmerer,2024,57,25,20
-Kemmerer,2024,58,30.1824680583792,21.640365448504983
+Kemmerer,2024,58,30,22
-Kemmerer,2024,59,33.034354804052825,21.80066445182724
+Kemmerer,2024,59,33,22
-Kemmerer,2024,60,24.58166576527853,13.547851248526417
+Kemmerer,2024,60,25,14
-Kemmerer,2024,61,25.752221277910838,15.305969349480229
+Kemmerer,2024,61,26,15
-Kemmerer,2024,62,23.212805992871722,17.31788012362568
+Kemmerer,2024,62,23,17
-Kemmerer,2024,63,23.212805992871722,16.868065055479555
+Kemmerer,2024,63,23,17
-Kemmerer,2024,64,24.42654748269508,17.430333890662205
+Kemmerer,2024,64,24,17
-Kemmerer,2024,65,17.826584994462902,31.169037340601193
+Kemmerer,2024,65,18,31
-Kemmerer,2024,66,20.324577796234774,32.30936797501343
+Kemmerer,2024,66,20,32
-Kemmerer,2024,67,31.745589072282296,31.707002858013322
+Kemmerer,2024,67,32,32
-Kemmerer,2024,68,31.745589072282296,32.5413976700663
+Kemmerer,2024,68,32,33
-Kemmerer,2024,69,29.161645775701185,31.289805451986826
+Kemmerer,2024,69,29,31
-Kemmerer,2024,70,27.118003770017854,15.476896504155697
+Kemmerer,2024,70,27,15
-Kemmerer,2024,71,25.59022890973516,15.122463759785719
+Kemmerer,2024,71,26,15
-Kemmerer,2024,72,21.579819901493085,13.114011541689177
+Kemmerer,2024,72,22,13
-Kemmerer,2024,73,20.43398875628106,12.405146052949224
+Kemmerer,2024,73,20,12
-Kemmerer,2024,74,20.052045041210388,12.168857556702571
+Kemmerer,2024,74,20,12
-Kemmerer,2024,75,27.418452872826624,9.03148043108338
+Kemmerer,2024,75,27,9
-Kemmerer,2024,76,32.273803902389666,9.305161656267725
+Kemmerer,2024,76,32,9
-Kemmerer,2024,77,19.421404118252187,5.199943278502552
+Kemmerer,2024,77,19,5
-Kemmerer,2024,78,17.422141929608582,5.0174891283796565
+Kemmerer,2024,78,17,5
-Kemmerer,2024,79,15.994097509148864,5.108716203441104
+Kemmerer,2024,79,16,5
-Kemmerer,2024,80,7.746694691165502,5.8689063665333245
+Kemmerer,2024,80,8,6
-Kemmerer,2024,81,5.325852600176282,5.103396840463761
+Kemmerer,2024,81,5,5
-Kemmerer,2024,82,3.7523052410332904,5.358566682486948
+Kemmerer,2024,82,4,5
-Kemmerer,2024,83,3.510221031934368,4.465472235405791
+Kemmerer,2024,83,4,4
-Kemmerer,2024,84,3.389178927384908,4.2103023933826025
+Kemmerer,2024,84,3,4
-Kemmerer,2024,85,20.83887043189369,18.274086378737543
+Kemmerer,2024,85,21,18

Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Summary_Start_Data.csv

@@ -1,2 +1,2 @@
 Year,County,Population,Births,Deaths,Migration,Min_Birth_Group,PREV_BIRTH,PREV_TWO_BIRTH
-2024,Kemmerer,2895,NA,NA,NA,125.89845094664372,29,37
+2024,Kemmerer,2895,NA,NA,NA,126,29,37

Demographic_Split.r

@@ -4,6 +4,7 @@ ACS_FILE_LOC <- "Data/Cleaned_Data/ACS_Census_Demographic_Data.Rds"
 ACS_YEAR <- 2023 #Year of the ACS data
 if(!file.exists(ACS_FILE_LOC)){source("Scripts/Load_ACS_Census_Data.r")}else{AGE_DATA <- readRDS(ACS_FILE_LOC)}
 LIN_DEMOGRAPHICS <-    	readRDS("Data/Cleaned_Data/Lincoln_Demographic_Data.Rds") %>% filter(Year==ACS_YEAR)
+
 for(i in 1:nrow(AGE_DATA)){
 	if(i==1 & exists("RES")){rm(RES)}
 	C_DEMO <-	AGE_DATA[i,]
@@ -20,7 +21,7 @@ for(i in 1:nrow(AGE_DATA)){
 }
 RES <- RES %>% group_by(IN_KEM) %>% mutate(Per_Pop=Population/sum(Population)) %>% mutate(Region=ifelse(IN_KEM,'Kemmerere & Diamondville','Rest of the County')) %>% select(-Population) %>% ungroup
 CURRENT_KEM_POP <- readRDS("Data/Cleaned_Data/Wyoming_City_Population.Rds")  %>% filter(City %in% c('Kemmerer','Diamondville'),Year==max(Year)) %>% mutate(Population=as.numeric(Population)) %>% pull(Population) %>% sum()
-KEM_DEMOGRAPHICS <- RES %>% filter(IN_KEM==1) %>% select(Age,Sex,Per_Pop) %>% mutate(Year=ACS_YEAR+1,County='Kemmerer',Population=Per_Pop*CURRENT_KEM_POP ) %>% select(-Per_Pop) %>% pivot_wider(values_from=Population,names_from=c(Sex),names_prefix="Num_") %>% select(County,Year,Age,Num_Male,Num_Female)
+KEM_DEMOGRAPHICS <- RES %>% filter(IN_KEM==1) %>% select(Age,Sex,Per_Pop) %>% mutate(Year=ACS_YEAR+1,County='Kemmerer',Population=round(Per_Pop*CURRENT_KEM_POP) ) %>% select(-Per_Pop) %>% pivot_wider(values_from=Population,names_from=c(Sex),names_prefix="Num_") %>% select(County,Year,Age,Num_Male,Num_Female)
 	saveRDS(KEM_DEMOGRAPHICS,"Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Demographic_Data.Rds")
 	write_csv(KEM_DEMOGRAPHICS,"Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Demographic_Data.csv")
 
@@ -30,6 +31,40 @@ KEM_DEMOGRAPHICS <- RES %>% filter(IN_KEM==1) %>% select(Age,Sex,Per_Pop) %>% mu
 	INTIATE_KEMMER <- KEM_DEMOGRAPHICS %>% mutate(Male_Window=Age>=18 & Age<=30,Female_Window=Age>=18 & Age<=28) %>% group_by(County,Year) %>% summarize(Female_Birth_Group=sum(Num_Female*Female_Window),Male_Birth_Group=sum(Num_Male*Male_Window),Min_Birth_Group=ifelse(Female_Birth_Group<Male_Birth_Group,Female_Birth_Group,Male_Birth_Group),PREV_BIRTH=ST_BIRTH_KEM,PREV_TWO_BIRTH=ST_BIRTH_TWO_PREV_KEM,Population=CURRENT_KEM_POP) %>% mutate(Births=NA,Deaths=NA,Migration=NA) %>% select(Year,County,Population,Births,Deaths,Migration,Min_Birth_Group,PREV_BIRTH,PREV_TWO_BIRTH) %>% ungroup
 	saveRDS(INTIATE_KEMMER ,"Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Summary_Start_Data.Rds")
 	write_csv(INTIATE_KEMMER ,"Data/Cleaned_Data/Intiate_Simulation/Kemmerer_Summary_Start_Data.csv")
+###Create data sets that contain all people not in Loncoln but not Kemmerer or Diamondville, for a seperate comparison run
+LIN_DEMOGRAPHICS_RECENT  <-    	readRDS("Data/Cleaned_Data/Lincoln_Demographic_Data.Rds") %>% filter(Year==max(Year)) #Grab the most recent year of data for all of the county
+LIN_OTHER_DEMOGRAPHICS <-  LIN_DEMOGRAPHICS_RECENT  %>% left_join(KEM_DEMOGRAPHICS %>% select(-County,ADJ_MALE=Num_Male,ADJ_FEMALE=Num_Female)) %>% mutate(Num_Male=Num_Male-ADJ_MALE,Num_Female=Num_Female-ADJ_FEMALE) %>% select(-ADJ_MALE,-ADJ_FEMALE) %>% ungroup#Deduct the populaiton estimates of Kemmerer to create a "Other Lincoln" data set
+#Data sets needed to start a simulation for all but Kemmerer/Diamondville but in the county
+	ST_BIRTH_OTHER <- round(sum((LIN_OTHER_DEMOGRAPHICS%>% filter(Age==0))[4:5]))
+	ST_BIRTH_TWO_PREV_OTHER <- round(sum((LIN_OTHER_DEMOGRAPHICS%>% filter(Age==1))[4:5]))
+	INTIATE_OTHER <- LIN_OTHER_DEMOGRAPHICS %>% mutate(Male_Window=Age>=18 & Age<=30,Female_Window=Age>=18 & Age<=28) %>% group_by(County,Year) %>% summarize(Female_Birth_Group=sum(Num_Female*Female_Window),Male_Birth_Group=sum(Num_Male*Male_Window),Min_Birth_Group=ifelse(Female_Birth_Group<Male_Birth_Group,Female_Birth_Group,Male_Birth_Group),PREV_BIRTH=ST_BIRTH_OTHER,PREV_TWO_BIRTH=ST_BIRTH_TWO_PREV_OTHER,Population=CURRENT_KEM_POP) %>% mutate(Births=NA,Deaths=NA,Migration=NA) %>% select(Year,County,Population,Births,Deaths,Migration,Min_Birth_Group,PREV_BIRTH,PREV_TWO_BIRTH) %>% ungroup
+	#Save detailed demographics for start of analysis
+	saveRDS(LIN_OTHER_DEMOGRAPHICS,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_Rest_of_County_Demographic_Data.Rds")
+	write_csv(LIN_OTHER_DEMOGRAPHICS,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_Rest_of_County_Demographic_Data.csv")
+
+	#Save summary information for start of analysis 
+
+	saveRDS(INTIATE_OTHER ,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_Rest_of_County_Summary_Start_Data.Rds")
+	write_csv(INTIATE_OTHER ,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_Rest_of_County_Summary_Start_Data.csv")
+
+
+#Data sets needed to start a simulation for all the county (includes Kemmerer)
+	ST_BIRTH_ALL <- round(sum((LIN_DEMOGRAPHICS_RECENT %>% filter(Age==0))[4:5]))
+	ST_BIRTH_TWO_PREV_ALL <- round(sum((LIN_DEMOGRAPHICS_RECENT %>% filter(Age==1))[4:5]))
+	INTIATE_ALL <- LIN_DEMOGRAPHICS_RECENT %>% mutate(Male_Window=Age>=18 & Age<=30,Female_Window=Age>=18 & Age<=28) %>% group_by(County,Year) %>% summarize(Female_Birth_Group=sum(Num_Female*Female_Window),Male_Birth_Group=sum(Num_Male*Male_Window),Min_Birth_Group=ifelse(Female_Birth_Group<Male_Birth_Group,Female_Birth_Group,Male_Birth_Group),PREV_BIRTH=ST_BIRTH_ALL,PREV_TWO_BIRTH=ST_BIRTH_TWO_PREV_ALL,Population=CURRENT_KEM_POP) %>% mutate(Births=NA,Deaths=NA,Migration=NA) %>% select(Year,County,Population,Births,Deaths,Migration,Min_Birth_Group,PREV_BIRTH,PREV_TWO_BIRTH) %>% ungroup
+	#Save detailed demographics for start of analysis
+	saveRDS(LIN_DEMOGRAPHICS_RECENT,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_All_County_Demographic_Data.Rds")
+	write_csv(LIN_DEMOGRAPHICS_RECENT,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_All_County_Demographic_Data.csv")
+
+	#Save summary information for start of analysis 
+
+	saveRDS(INTIATE_ALL ,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_All_County_Summary_Start_Data.Rds")
+	write_csv(INTIATE_ALL ,"Data/Cleaned_Data/Intiate_Simulation/Lincoln_All_County_Summary_Start_Data.csv")
+
+
+#sum(LIN_OTHER_DEMOGRAPHICS[,4:5] )+sum(KEM_DEMOGRAPHICS[,4:5])
+
+
 ###Make a population Pyramid Graph
 PY_KEM_DATA <- KEM_DEMOGRAPHICS %>% mutate(County='Kemmerer') %>% pivot_longer(cols=c(Num_Male,Num_Female),names_to="Sex",values_to="Population") %>% mutate(Sex=ifelse(Sex=='Num_Male','Male','Female'))
 PY_LN_DATA <- readRDS("Data/Cleaned_Data/Wyoming_County_Demographic_Data.Rds") %>% filter(County=='Lincoln',Year==max(Year))%>% pivot_longer(cols=c(Num_Male,Num_Female),names_to="Sex",values_to="Population") %>% mutate(Sex=ifelse(Sex=='Num_Male','Male','Female'))
@@ -44,13 +79,23 @@ PY_LN_DATA$Percent <- PY_LN_DATA$Population/LN_ONLY_POP
 KEM_ONLY_POP <- sum(PY_KEM_DATA$Population)
 PY_KEM_DATA$Percent <- PY_KEM_DATA$Population/KEM_ONLY_POP 
 
-PY_DATA <- rbind(PY_LN_DATA,PY_KEM_DATA) %>% mutate(Population=ifelse(County=='Kemmerer',Population,-Population),'Percent Population'=ifelse(County=='Kemmerer',Percent,-Percent),Age_Numeric=Age,Age=as.character(Age))
+PY_DATA <- rbind(PY_LN_DATA,PY_KEM_DATA) %>% mutate(Population=ifelse(County=='Kemmerer',Population,-Population),'Percent of Population'=ifelse(County=='Kemmerer',Percent,-Percent),Age_Numeric=Age,Age=as.character(Age))
 PY_DATA[PY_DATA$Age=='85',"Age"] <- ">84"
 ORD <- PY_DATA[,c("Age_Numeric","Age")] %>% unique %>% arrange(Age_Numeric) %>% pull(Age)
 PY_DATA$Age <- factor(PY_DATA$Age,levels=ORD)
 
-RANGE <- c(pretty(range(PY_DATA$`Percent Population`),n=8))
+RANGE <- c(pretty(range(PY_DATA$`Percent of Population`),n=4))
 LAB <- 	percent(abs(RANGE),accuracy=0.1 )
- POP_PYRAMID <- ggplot(PY_DATA,aes(y=factor(Age),x=`Percent Population`,fill=County))+geom_col() +scale_x_continuous(breaks  = RANGE,labels = LAB)+facet_grid(~Sex)
+PY_DATA 
-POP_PYRAMID 
+PY_DATA <- PY_DATA %>% mutate(Region=ifelse(County=='Lincoln',"Rest of Lincoln County","Kemmerer & Diamondville"))
+PY_DATA$Sex <- ifelse(PY_DATA$Sex=='Male','Men','Women')
+ORDER <- PY_DATA$Sex %>% unique
+PY_DATA$Sex <-	factor(PY_DATA$Sex,levels=ORDER)
+ POP_PYRAMID <- ggplot(PY_DATA,aes(y=factor(Age),x=`Percent of Population`,fill=Region))+geom_col() +scale_x_continuous(breaks  = RANGE,labels = LAB)+facet_grid(~Sex)+ylab("Age")+ theme_bw()+ theme(axis.text = element_text(size = 10),legend.position = "top",legend.text=element_text(size=14),legend.title = element_blank(),axis.title=element_text(size=18),strip.text = element_text(size = 14))
+
+
+dir.create(FIG_DIR ,showWarnings=FALSE)
+png(paste0(FIG_DIR,"/Population_Pyramid.png"), res = 600, width = 8.27, height = 11, units = "in")
+	POP_PYRAMID
+dev.off()