59 lines
3.3 KiB
R
59 lines
3.3 KiB
R
#These functions are used to take census data from Kemmerer in 2020, and find the relative ratio of the total population in Lincoln. This allows for a heuristic of the current year age-sex demographic amounts in 2025 of Kemmerer to start the Monte Carlo with a list age people in each age group
|
|
|
|
#A function to pull an estimate of the ratio between the Kemmerer are age-sex population cohort, and the Lincoln total. This allows the age-sex by year demographic data for Lincoln to be converted to Kemmerer numbers. Used as in input to TRANSPOSE_AGE_DEMOGRAPHIC_DATA_DOWN (see below)
|
|
GET_VALUE <- function(Age,SEX,DATA=AGE_DATA,County='Lincoln'){
|
|
DATA <- DATA %>% filter(Region==County,Sex==SEX)
|
|
if(any(Age==DATA$Med_Age)){
|
|
#If any exact matches in between the min and max ages pull the exact record
|
|
RES <- DATA[which(Age==DATA$Med_Age & DATA$Sex==SEX),] %>% pull(Per_Pop)
|
|
}else if(Age>=85){
|
|
RES <- DATA[which(DATA$Min_Age==85 & DATA$Max_Age==Inf),] %>% pull(Per_Pop)
|
|
}else if(Age>=85){
|
|
#If in the upper bound of age pull the single record
|
|
RES <- DATA[which(DATA$Min_Age==85 & DATA$Max_Age==Inf),] %>% pull(Per_Pop)
|
|
}else if(Age==0){
|
|
#If in the lower bound of age pull the single record
|
|
RES <- DATA[which(DATA$Min_Age==0),] %>% pull(Per_Pop)
|
|
}else{
|
|
#If no exact record is found perform a linear interpolation between the two age brackets bounding the point
|
|
TEMP <- DATA %>% arrange(Min_Age) %>% select(Med_Age,Min_Age,Max_Age,Per_Pop) %>% filter(Per_Pop!=0)
|
|
LOWER <- TEMP[max(max(which(TEMP$Med_Age<Age)),1),] #Find the lowest value in the list but if no match is found pull the first record
|
|
UPPER <- TEMP[min(which(TEMP$Med_Age>Age)),]
|
|
if(LOWER$Med_Age!=UPPER$Med_Age){
|
|
#If the LOWER and UPPER are the same than the age must be less the first entry, if that is not true perform a linear interpolation between the two bounding entries
|
|
C <- LOWER$Med_Age
|
|
ST <- LOWER$Per_Pop
|
|
DELTA <- UPPER$Per_Pop-LOWER$Per_Pop
|
|
GAP <- UPPER$Med_Age-LOWER$Med_Age
|
|
RES <- (ST+(Age-C)*DELTA/GAP)
|
|
} else{RES <- UPPER %>% pull(Per_Pop)}
|
|
}
|
|
return(RES)
|
|
}
|
|
#A function which returns a tibble of all single year age-sex combinations for conversions of ratio in Lincoln to Kemmerer
|
|
INTERPOLATE_COUNTY_AGE_DEMOGRAPHIC_DATA_TO_CITY_LEVEL <- function(DATA,COUNTY='Lincoln',AGE_RANGE=0:85,YEARS_FORWARD=0){
|
|
#Create a vector of all male ages, then all female ages
|
|
VALUES <- c(unlist((sapply(AGE_RANGE,function(x){GET_VALUE(x,'Male',DATA,COUNTY)}))),unlist((sapply(AGE_RANGE,function(x){GET_VALUE(x,'Female',DATA,COUNTY)}))))
|
|
#Turn into an easy to read tibble to merge later with the actual demographic data
|
|
RES <- cbind(rep(AGE_RANGE,2),c(rep("Male",length(VALUES)/2),rep("Female",length(VALUES)/2)),VALUES) %>% as_tibble
|
|
colnames(RES) <- c("Age","Sex","Conversion_Ratio")
|
|
RES <- RES %>% mutate(Age=as.numeric(Age),Conversion_Ratio=as.numeric(Conversion_Ratio))
|
|
if(YEARS_FORWARD>0){
|
|
MALE <- RES %>% filter(Sex=='Male')
|
|
FEMALE <- RES %>% filter(Sex=='Female')
|
|
STUB_AGE_MALE <- MALE[rep(1,YEARS_FORWARD),]
|
|
STUB_AGE_MALE$Age <- 0:(YEARS_FORWARD-1)
|
|
|
|
STUB_AGE_FEMALE <- FEMALE[rep(1,YEARS_FORWARD),]
|
|
STUB_AGE_FEMALE$Age <- 0:(YEARS_FORWARD-1)
|
|
|
|
MALE[,"Age"] <- MALE[,"Age"]+YEARS_FORWARD
|
|
FEMALE[,"Age"] <- FEMALE[,"Age"]+YEARS_FORWARD
|
|
MALE <- rbind(STUB_AGE_MALE,MALE)[1:nrow(MALE),]
|
|
FEMALE <- rbind(STUB_AGE_FEMALE,FEMALE)[1:nrow(FEMALE),]
|
|
RES <- rbind(MALE,FEMALE)
|
|
}
|
|
return(RES)
|
|
}
|
|
|