Created Kemmerer to LN conversion function

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_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)
+}
+

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
+LIN_TO_KEMMER_CONVERSION_RATIOS <- INTERPOLATE_COUNTY_AGE_DEMOGRAPHIC_DATA_TO_CITY_LEVEL(AGE_DATA,YEARS_FORWARD=5)
-SEX <- 'Male'
+LIN_TO_KEMMER_CONVERSION_RATIOS 
-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_Age<Age)),]
-	UPPER <- TEMP[min(which(TEMP$Med_Age>Age)),]
-	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)
 
 
- 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))