111 lines
11 KiB
R
111 lines
11 KiB
R
##########################Model Migration Trends for use in the Monte Carlo. This is important because a 18 year old is more likely to move than 75 year old.
|
|
library(tidyverse)
|
|
library(fixest)
|
|
library(scales)
|
|
######Checking correlations with migration rates
|
|
DEMOGRAPHIC_DATA <- readRDS("Data/Cleaned_Data/Demographic_Sex_Age_Data/RDS/All_Wyoming_Counties_Demographics.Rds")
|
|
#Extract the population trend data to connect with demographics (Population,births,deaths)
|
|
POP_DATA <- readRDS("Data/Cleaned_Data/Population_Data/RDS/All_Wyoming_County_Populations.Rds")
|
|
#Identify births, deaths an migration from existing data.
|
|
DEMO1 <- DEMOGRAPHIC_DATA
|
|
DEMO2 <- DEMOGRAPHIC_DATA %>% mutate(Year=Year+1,Age=Age+1) %>% rename(PREV_MALE=Num_Male,PREV_FEMALE=Num_Female)
|
|
#Combine into a usable data set. Calculate the change in the age-sex population from year to year. This change will include the effect of migration, where absolute values are a mix of factors unrelated to migration. This first-difference approach is preferred to absolute values.
|
|
DEMO_DATA <- inner_join(DEMO1,DEMO2) %>% mutate(Male=Num_Male-PREV_MALE,Female=Num_Female-PREV_FEMALE,Pop_Change=Male+Female) %>% select(County,Year,Age,Male,Female,Pop_Change) %>% arrange(County,Year,Age)
|
|
#############################Observed that men and women behave similarly allowing for the groups to be combined
|
|
COR_MAT_DATA_FULL <- pivot_wider(DEMO_DATA,values_from=c(Male,Female),names_from=Age)
|
|
COR_MAT_DATA_FULL <- POP_DATA %>% left_join(COR_MAT_DATA_FULL )
|
|
|
|
#########################################
|
|
#Create a wide data set with ages in each column so that each regression of age can be predicted one by one.
|
|
#Use the previous years population data as the starting point, so that the regression does not use data already including migration.
|
|
DEMO_DATA <- DEMO_DATA %>% select(-Male,-Female)
|
|
COR_MAT_DATA_FULL <- pivot_wider(DEMO_DATA,values_from=Pop_Change,names_from=Age,names_prefix="Age_")
|
|
AGE_WIDE_DATA <- POP_DATA %>% mutate(Population=Population-Migration-Births+Deaths) %>% left_join( COR_MAT_DATA_FULL) %>% filter(!is.na(Migration),!is.na(Deaths),!is.na(Population),!is.na(Year),!is.na(County))
|
|
|
|
#Create a table to store the resulting coefficients in.
|
|
RES <- cbind(1:90,c(rep("Child",17),"18",rep("Adult",90-18)),rep(NA,90),rep(NA,90)) %>% as_tibble
|
|
#Clean the output table
|
|
colnames(RES ) <- c("Age","Group","MIGRATION_COEF","DEATH_COEF")
|
|
RES$Age<- as.numeric(RES$Age)
|
|
RES$MIGRATION_COEF <- as.numeric(RES$MIGRATION_COEF)
|
|
RES$DEATH_COEF <- as.numeric(RES$DEATH_COEF)
|
|
RES$Group <-factor(RES$Group,levels=c("Child","18","Adult"))
|
|
|
|
#Predicating the effect of migration on population in any one age group, so that trends over age can be observed. Less when old, more when 18-19.
|
|
#Loop over all age groups, predict number of people in the age group, from previous population, deaths, and Migrations. Extract the Migration Coefficient for use in a trend analysis.
|
|
for(x in 1:90){
|
|
AGE_WIDE_DATA$Y_VAL <- as.numeric(t(AGE_WIDE_DATA[,6+x]))#Extract the change
|
|
C_REG<- feols(Y_VAL~Deaths+Migration+Population|Year+County,data=AGE_WIDE_DATA)
|
|
RES[x,3] <- as.numeric(coef(C_REG)["Migration"])
|
|
RES[x,4] <- as.numeric(coef(C_REG)["Deaths"])
|
|
}
|
|
rm(C_REG)
|
|
#Create Location to save analysis figures or tables
|
|
if(!exists("FIG_SAVE_LOC")){FIG_SAVE_LOC <- "./Results/Migration_Trends/"}
|
|
dir.create(FIG_SAVE_LOC , recursive = TRUE, showWarnings = FALSE)
|
|
|
|
REG_1 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA %>% mutate(AGE=Age_1))
|
|
REG_5 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_5))
|
|
REG_10 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_10))
|
|
REG_15 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_15))
|
|
REG_18 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_18))
|
|
REG_25 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_25))
|
|
REG_35 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_35))
|
|
REG_45 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_45))
|
|
REG_55 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_55))
|
|
REG_65 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_65))
|
|
REG_75 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_75))
|
|
REG_85 <- feols(AGE~Deaths+Migration+Population|Year+County,cluster~County,data=AGE_WIDE_DATA%>% mutate(AGE=Age_85))
|
|
HEAD <- list(":_:Category"=list("Children"=4,"Eighteen"=1,"Adult"=4),list("Age 1","Age 5","Age 10","Age 15","Age 18","Age 25","Age 45","Age 65","Age 85"))
|
|
DICT <-c("AGE"='\\textbf{Yearly Change in Number of People by Age in Wyoming Counties}')
|
|
REG_TABLE_LOC <- paste0(FIG_SAVE_LOC,"Migration_by_Age_Regression.png")
|
|
REG_TEX_LOC <- paste0(FIG_SAVE_LOC,"Migration_by_Age_Regression.tex")
|
|
|
|
try(etable(REG_1,REG_5,REG_10,REG_15,REG_18,REG_25,REG_45,REG_65,REG_85,headers=HEAD,style.tex=style.tex(yesNo="$\\checkmark$"),dict=DICT,replace=TRUE,file=REG_TEX_LOC ,export=REG_TABLE_LOC))
|
|
try(etable(REG_1,REG_5,REG_10,REG_15,REG_18,REG_25,REG_45,REG_65,REG_85,headers=HEAD,style.tex=style.tex(yesNo="$\\checkmark$"),dict=DICT,replace=TRUE,file=REG_TEX_LOC ,export=REG_TABLE_LOC))
|
|
#Create data to create graphs and analyze. Remove some observed outlier
|
|
GRAPH_DATA <- RES %>% filter(abs(MIGRATION_COEF)<Inf,Age<100) %>% filter(Age!=25,Age!=35,Age!=85)
|
|
|
|
#Graph when not using log scale but including a geom_smooth to show the actual trend.
|
|
png(paste0(FIG_SAVE_LOC,"Coeffceints_of_Wyoming_County_Pop_Change_from_Migration_by_Age.png"), res = 600, width =11 , height = 8.27, units = "in")
|
|
ggplot(GRAPH_DATA,aes(x=Age,y=MIGRATION_COEF,group=Group,color=Group)) +geom_point()+geom_smooth(span=0.9)+ylab("Pop. Change Per Net Migration")+ 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))+scale_x_continuous(breaks=c(0,seq(5,90,by=5)))+ scale_color_manual(values = c("cornflowerblue","indianred2", "black"))
|
|
dev.off()
|
|
|
|
|
|
##Graph when using log scales and grouping by child/adult. Looks pretty linear
|
|
png(paste0(FIG_SAVE_LOC,"Coeffceints_of_Wyoming_County_Pop_Change_from_Migration_by_Age_Natual_Log_Scale.png"), res = 600, width =11 , height = 8.27, units = "in")
|
|
ggplot(GRAPH_DATA,aes(x=Age,y=(MIGRATION_COEF),group=Group,color=Group)) +geom_point()+geom_smooth(method="lm")+ylab("Pop. Change Per Net Migration (Nat. log)")+ 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))+scale_x_continuous(breaks=c(0,seq(5,90,by=5)))+ scale_color_manual(values = c("cornflowerblue","indianred2", "black"))+ scale_y_continuous(trans = scales::log_trans(),labels = scales::label_number())
|
|
dev.off()
|
|
####Create results which find a functional form for the probability that a migrant is in a certain age bracket, so that the probability of any age can be drawn from in the Monte Carlo for net migration numbers. Note that a function is used, because point estimates will have large variably, but the overall trend looks VERY clean.
|
|
CHILD_MOD <- lm(log(MIGRATION_COEF)~Age,data=GRAPH_DATA %>% filter(Group=='Child')) #The childhood range (1-18), has a great exponential fit with age, but has a different trend than adults. Because there are fewer data points we prefer a exponential fit, compared to a smoothed fit as the variance changes the end points, yet in both cases a exponential fit looks good.
|
|
CHILD_PRED <- exp(predict(CHILD_MOD))
|
|
#Extract only the 18 coefficient values. This falls cleanly in between the two groups which seems reasonable, however, it would not inexcusably make sense to assign exactly 18 to either child or adult trend.
|
|
PRED_18 <- as.numeric(GRAPH_DATA[GRAPH_DATA$Age==18,"MIGRATION_COEF"])
|
|
#Uses a local polynomial regression fitting model for adults. While this is nearly a exponential curve, some additional uncertainty can be captured since there is enough data to create a smooth line. A span of 0.9 is used rather than a lower number to avoid over-fitting to the high variance in year by year coefficients.
|
|
ADULT_MOD <- loess(MIGRATION_COEF~Age,data=GRAPH_DATA %>% filter(Group=='Adult'),span=0.9)
|
|
ADULT_PRED <- predict(ADULT_MOD,19:90)
|
|
#Create a data frame for the probabilities in each age. Include age, and child/adult indicators for convenience.
|
|
MIGRATION_COEF <- c(CHILD_PRED,PRED_18,ADULT_PRED) #Combine the predicting coefficients for each year 1 to 90.
|
|
Age <- 1:90 #Ages in the model are 1 to 90. No zero as these are included in births of the current year.
|
|
PRED_DATA <- cbind(MIGRATION_COEF,Age) %>% as_tibble
|
|
PRED_DATA$Group <- c(rep("Child",17),"18",rep("Adult",90-18))
|
|
#clean the data
|
|
PRED_DATA$Age <- as.numeric(PRED_DATA$Age)
|
|
MIN_VAL <- min(abs(as.numeric(MIGRATION_COEF))) #Some of the tail end estimates are very slightly less than zero. This is not possible, so instead put negative values, as the smallest magnitude observed in the other predictions.
|
|
PRED_DATA$MIGRATION_COEF<- ifelse(MIGRATION_COEF<MIN_VAL,MIN_VAL,MIGRATION_COEF)
|
|
|
|
#Convert the absolute coefficient values to a percentage chance that any one immigrant will be in the given age. This wont line up perfectly with the coefficients if using them to predict immigration, because the age-sex data set uses different totals than the population/migration data. However, the distribution should be the same, so we divide each estimate by the total. The results is the percent probability that a single independent immigrant will be of the given age.
|
|
#If this is run from the main script MIG_AGE_DIST will be the key variable and should not be changed.
|
|
MIG_AGE_DIST <- PRED_DATA$MIGRATION_COEF/sum(PRED_DATA$MIGRATION_COEF)
|
|
#Condense down to 85+ group because death rates only use 85+
|
|
MIG_AGE_DIST[85] <- mean(MIG_AGE_DIST[85:90])
|
|
MIG_AGE_DIST <- MIG_AGE_DIST[1:85]
|
|
MIG_AGE_DIST <- c(MIG_AGE_DIST[1],MIG_AGE_DIST)%>% as.vector
|
|
MIG_AGE_DIST <- MIG_AGE_DIST/sum(MIG_AGE_DIST)
|
|
#Create Location to probability results
|
|
if(!exists("RES_SAVE_LOC")){RES_SAVE_LOC <- "./Data/Intermediate_Inputs/"}
|
|
dir.create(RES_SAVE_LOC , recursive = TRUE, showWarnings = FALSE)
|
|
|
|
write.csv(MIG_AGE_DIST ,paste0(RES_SAVE_LOC,"Migration_Age_Probablity_Zero_to_85.csv"),row.names=FALSE)
|
|
saveRDS(MIG_AGE_DIST ,paste0(RES_SAVE_LOC,"Migration_Age_Probablity_Zero_to_85.Rds"))
|