From 628a601d6b5a24e1eae8dd982f4e33bdf3cd30a7 Mon Sep 17 00:00:00 2001 From: Alex Gebben Work Date: Mon, 3 Nov 2025 11:36:53 -0700 Subject: [PATCH] Created Kemmerer to LN conversion function --- Scripts/Downshift_Population_Functions.r | 58 ++++++++++++++++++++++++ Zip_Code.r | 29 ++---------- 2 files changed, 63 insertions(+), 24 deletions(-) create mode 100644 Scripts/Downshift_Population_Functions.r diff --git a/Scripts/Downshift_Population_Functions.r b/Scripts/Downshift_Population_Functions.r new file mode 100644 index 0000000..1109ddb --- /dev/null +++ b/Scripts/Downshift_Population_Functions.r @@ -0,0 +1,58 @@ +#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_AgeAge)),] + 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) +} + diff --git a/Zip_Code.r b/Zip_Code.r index b9de11b..04d52bd 100644 --- a/Zip_Code.r +++ b/Zip_Code.r @@ -1,6 +1,7 @@ library(tidyverse) library(tidycensus) library(zipcodeR) +source("Scripts/Downshift_Population_Functions.r") #Packages to instal on computer if zipcodeR won't install #Sudo apt install libssl-dev libudunits2-dev libabsl-dev libcurl4-openssl-dev libgdal-dev cmake libfontconfig1-dev libharfbuzz-dev libfribidi-dev #install.packages("zipcodeR") @@ -39,7 +40,7 @@ AGE_DATA[AGE_DATA$Min_Age==0,"Ages"] <- "Under 5" #Turn the ages into factors to keep the correct order in graphs ORD <- AGE_DATA %>% select(Min_Age,Ages) %>% unique %>% arrange(Min_Age) %>% pull(Ages) %>% unique AGE_DATA$Ages <- factor(AGE_DATA$Ages,levels=ORD) -#Add the percent of total relative population in theregion +#Add the percent of total relative population in the region AGE_DATA <- AGE_DATA %>% mutate(Per_Pop=Population/sum(Population)) %>% group_by(IN_KEM) %>% mutate(Per_Pop_Region=Population/sum(Population)) %>% ungroup #Add a region name for clearer graphs @@ -48,33 +49,13 @@ AGE_DATA <- AGE_DATA %>% mutate(Region=ifelse(IN_KEM==1,'Kemmerer','Lincoln')) PLOT <- ggplot(AGE_DATA, aes(x =Ages, y = Per_Pop_Region)) + geom_line() + geom_point(aes(color = Region ), size = 5) + scale_color_brewer(palette = "Set1", direction = 1) + theme(legend.position = "bottom")+facet_wrap(~Sex,ncol=1) #PLOT -Age <- 13 -SEX <- 'Male' -DATA <- AGE_DATA -GET_VALUE <- function(Age,SEX,DATA=AGE_DATA){ - DATA <- DATA %>% filter(Region=='Lincoln',Sex==Sex) - if(any(Age==DATA$Med_Age)){ - return(DATA[which(Age==DATA$Med_Age),] %>% pull(Per_Pop)) -} - TEMP <- DATA %>% arrange(Min_Age) %>% select(Med_Age,Min_Age,Max_Age,Per_Pop) %>% filter(Per_Pop!=0) - LOWER <- TEMP[max(which(TEMP$Med_AgeAge)),] - C <- LOWER$Med_Age - ST <- LOWER$Per_Pop - DELTA <- UPPER$Per_Pop-LOWER$Per_Pop - GAP <- UPPER$Med_Age-LOWER$Med_Age -return(ST+(Age-C)*DELTA/GAP) -} -GET_VALUE(27,"Male",AGE_DATA) +LIN_TO_KEMMER_CONVERSION_RATIOS <- INTERPOLATE_COUNTY_AGE_DEMOGRAPHIC_DATA_TO_CITY_LEVEL(AGE_DATA,YEARS_FORWARD=5) +LIN_TO_KEMMER_CONVERSION_RATIOS + - AGE_DATA %>% filter(Med_Age<=x,Med_Age>=x,Sex==SEX) %>% arrange(Min_Age) - -TEMP -TEMP[,"Per_Pop"] -AGE_FORWARD AGE_FORWARD <- AGE_DATA %>% filter(!(Min_Age==0 & Max_Age==Inf))%>% mutate(POP_TOTAL=POP_OUT+POP_KEM,KEM_RATIO=POP_KEM/POP_TOTAL) %>% select(Sex,Min_Age,Max_Age,KEM_RATIO) STORE <- AGE_FORWARD %>% filter(Min_Age==0,Max_Age==4) AGE_FORWARD <- STORE %>% full_join(AGE_FORWARD %>% mutate(Min_Age=Min_Age+4,Max_Age=Max_Age+4))