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

Working on out migration function update.

Browse Source
This commit is contained in:
Alex Gebben Work 2025-11-18 12:34:37 -07:00
parent 3941c5d6ea
commit ef3e529063
1 changed files with 67 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
Scripts/2E_Move_Current_Demographic_Data_to_Current_Year.r
View File

@ -1,19 +1,79 @@
library(tidyverse)
#setwd("../")
#Script to increment the migration, and death data to start simulation in 2024, projecting 2025
ODDS_MIGRATE <- readRDS("Data/Intermediate_Inputs/Migration_Trends/Migration_Age_Probablity_Zero_to_85.Rds")
KEM_CURRENT <- readRDS("Data/Intermediate_Inputs/Starting_Demographic_Data_Sets_of_Monte_Carlo/2023_Starting_Kemmerer_Diamondville_Demographics_Matrix.Rds")
KEM_CURRENT_POP <- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds")
num_migrated <- KEM_CURRENT_POP %>% filter(Year==2023) %>% pull(Migration) %>% abs
ODDS_LEAVE <- readRDS("Data/Intermediate_Inputs/Migration_Trends/Migration_Age_Probablity_Zero_to_85.Rds")
KEM_DEMOGRAPHIC <- readRDS("Data/Intermediate_Inputs/Starting_Demographic_Data_Sets_of_Monte_Carlo/2023_Starting_Kemmerer_Diamondville_Demographics_Matrix.Rds")
NUM_MIGRATED_OUT<- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(Year==2023) %>% pull(Migration) %>% abs
MIGRATED_OUT <- function(KEM_CURRENT,NUM_MIGRATED_OUT,ODDS_MIGRATED){
POP_TOTAL <- sum(KEM_CURRENT)
if(POP_TOTAL>NUM_MIGRATED_OUT){
RES_MAT <- matrix(NA,nrow=POP_TOTAL,ncol=2)
RES_MAT[,2] <- c(rep(1,sum(KEM_CURRENT[,1])),rep(2,sum(KEM_CURRENT[,2])))
DEM_LIST <- as.vector(KEM_CURRENT)
ODDS_SET <- rep(ODDS_MIGRATED,2)
ODDS_RES <- matrix(NA,ncol=1,nrow=POP_TOTAL)
for(i in 1:172){
ST <- min(which(is.na(RES_MAT)))
NUM_REP <- DEM_LIST[i]
if(NUM_REP>0){
RES_MAT[ST:(NUM_REP+ST-1)] <- rep(i,NUM_REP )
ODDS_RES[ST:(NUM_REP+ST-1)] <- rep(ODDS_SET[i],NUM_REP)
}
}
RES_MAT[,1] <- RES_MAT[,1]-86*(RES_MAT[,2]-1)
NOT_MIGRATED <- RES_MAT[sample(1:nrow(RES_MAT),POP_TOTAL-NUM_MIGRATED_OUT,prob=1-ODDS_RES,replace=FALSE),]
if(POP_TOTAL-NUM_MIGRATED_OUT==1){
OUT <- as.matrix(t(NOT_MIGRATED),nrow=1,ncol=2)
rownames(OUT) <- OUT[1]-1
MALE_FEMALE <- OUT[2]
OUT[MALE_FEMALE] <- 1
OUT[-MALE_FEMALE] <- 0
OUT[1] <- 1
}else{
OUT <- table(NOT_MIGRATED[,1],NOT_MIGRATED[,2])
if(ncol(OUT)==1){
OUT_ORIG <- OUT
NEW_COL_INDEX <- as.character(which(!(c(1,2) %in% colnames(OUT) )))
OUT <- cbind(OUT,rep(0,nrow(OUT)))
colnames(OUT) <- c(colnames(OUT)[1],NEW_COL_INDEX)
OUT <- OUT[,c("1","2")]
}
rownames(OUT) <- as.numeric(rownames(OUT))-1
}
colnames(OUT) <- c("Num_Male","Num_Female" )
if(nrow(OUT)<86){
ZERO_ROWS <- 0:85
ZERO_ROWS <- ZERO_ROWS[!(0:85 %in% rownames(OUT))]
OUT <- rbind(OUT,matrix(0,nrow=length(ZERO_ROWS),ncol=2,dimnames=list(ZERO_ROWS,colnames(OUT))))
OUT <- OUT[as.character(sort(as.numeric(rownames(OUT)))),]
}
} else{
OUT <- matrix(0,nrow=86,ncol=2,dimnames=list(0:85,colnames(KEM_CURRENT)))}
return(OUT)
}
ODDS_LEAVE <- readRDS("Data/Intermediate_Inputs/Migration_Trends/Migration_Age_Probablity_Zero_to_85.Rds")
KEM_DEMOGRAPHIC <- readRDS("Data/Intermediate_Inputs/Starting_Demographic_Data_Sets_of_Monte_Carlo/2023_Starting_Kemmerer_Diamondville_Demographics_Matrix.Rds")
NUM_MIGRATED_OUT<- readRDS("Data/Cleaned_Data/Population_Data/RDS/Kemmerer_Diamondville_Population_Data.Rds") %>% filter(Year==2023) %>% pull(Migration) %>% abs
start_time <- Sys.time()
for(x in 1:round(10^6/23)){MIGRATED_OUT(KEM_DEMOGRAPHIC,NUM_MIGRATED_OUT,ODDS_LEAVE)}
end_time <- Sys.time()
end_time - start_time
head(KEM_CURRENT)
LENGTH <- length(KEM_CURRENT)
for(x in 1:10^5){
for(x in 1:10^6){
KEM_NEW <- KEM_CURRENT
for(i in 1:num_migrated){
MIGRATED <- sample(1:LENGTH,1,prob=1-(1-ODDS_MIGRATE)^KEM_CURRENT)
KEM_NEW[MIGRATED]
KEM_NEW[MIGRATED] <- KEM_NEW[MIGRATED]-1
}
if(x==1){RES <- KEM_CURRENT-KEM_NEW} else{RES<- cbind(RES,KEM_NEW-KEM_CURRENT)}
# if(x==1){RES <- KEM_CURRENT-KEM_NEW} else{RES<- cbind(RES,KEM_NEW-KEM_CURRENT)}
}
plot((rowMeans(RES)))