############################################################################################################################## ############################################################################################################################## ##R CODE FOR ANNUAL POPULATION ESTIMATES BY AGE AND SEX, GIVEN LITTLE DATA (MULTIPLE COUNTIES) ## ##EDDIE HUNSINGER, JANUARY 2011 (LAST UPDATED SEPTEMBER 5, 2011) ##http://www.demog.berkeley.edu/~eddieh/ ##edynivn@gmail.com ## ##A WRITEUP WITH FULL EXPLANATION IS FORTHCOMING, BUT HERE IS A LINK TO THE INITIAL IDEA I HAD (EDITS SINCE): http://www.google.com/reader/item/tag:google.com,2005:reader/item/50ae883a25bee913 ##THE ESTIMATES USE/REQUIRE THE COUNTY COUNTS BY AGE AND SEX FROM THE LAST TWO CENSUSES, A GENERIC GROSS MIGRATION PROFILE, A GENERIC LIFE TABLE AND ANNUAL COUNTS FOR BIRTHS AND NET MIGRATION ## ##TO RUN THE CODE, YOU SHOULD BE ABLE TO SIMPLY SELECT ALL AND PASTE INTO R ##IDEALLY, THE USER WOULD CONTROL (WITH ITERATIVE PROPORTIONAL FITTING (http://www.demog.berkeley.edu/~eddieh/datafitting.html)) COUNTY ESTIMATES MADE THIS WAY UP TO MORE CAREFULLY MADE STATE ESTIMATES ##ALSO, THE USER WOULD MAKE MODIFICATIONS OR DISAGGREGATIONS FOR ANY PERCEIVED PROBLEMS, SUCH AS ESTIMATION OF PARTICULAR SPECIAL POPULATIONS ##THIS CODE/PROCESS MIGHT BE PARTICULARLY USEFUL FOR VERY SMALL AREAS, PERHAPS CONTROLLED UP TO COUNTIES ## ##IF YOU WOULD LIKE TO USE, SHARE OR REPRODUCE ANY INFORMATION OR IDEAS FROM THIS WORK, BE SURE TO CITE THE SOURCE ##THERE IS NO WARRANTY FOR THIS CODE ## ##PLEASE NOTE THAT I'VE FOUND PROBLEMS WITH THIS CODE (SEE STEP 11), AND IT IS A WORK IN PROGRESS ############################################################################################################################## ############################################################################################################################## ############################################################################################################################## ############################################################################################################################## ##Some more notes: (1) In this proposed way, migration is applied to age groups, and not cohorts--this may seem unrealistic, but if, alternatively, ##migration were applied to the cohorts (x-(10-n)), I think areas with special populations (such as college campuses) would be very poorly accounted, ##and, also, I'm hoping that controlling to more carefully done state estimates will smooth the problems of applying migration to the age groups. ##(2) This work may be nothing new at all-- I believe it is the same as a "plus-minus adjustment", and it parts that are like "Hamilton-Perry", and many ##other residual estimates works. ############################################################################################################################## ############################################################################################################################## ##DIMENSIONS SIZE<-91 STEPS<-20 AREAS<-65 ############################################################################################################################## #STEP 1: Doing one sex at a time, read in census county populations by age ############################################################################################################################## K<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/AgeSexCounty_90and00.csv",header=TRUE,sep=",") K<-as.matrix(K) KCensus1<-array(K[,2:66],c(SIZE,AREAS)) KCensus2<-array(K[,67:131],c(SIZE,AREAS)) ############################################################################################################################## #STEP 2: Subtract any "special population" (population by age that you want to hold fixed (such as college students) or manage separately #from the 1990 and 2000 county populations. ############################################################################################################################## Adjust<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/SpecialPopAdjustments_90and00.csv",header=TRUE,sep=",") Adjust<-as.matrix(Adjust) Adjust1<-array(Adjust[,2:66],c(SIZE,AREAS)) Adjust2<-array(Adjust[,67:131],c(SIZE,AREAS)) KBase1<-KCensus1-Adjust1 KBase2<-KCensus2-Adjust2 ############################################################################################################################## #STEP 3: Read in data on total annual births and set the fraction female at birth and fraction male at birth ############################################################################################################################## Births<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/Births_90sand00s.csv",header=TRUE,sep=",") Births<-as.matrix(Births) Births<-array(Births[,2:66],c(STEPS,AREAS)) ffab<-.4886 fmab<-1-ffab fab<-fmab ############################################################################################################################## #STEP 4: Read in a generic survival profile (for instance, I just use one for the US, 2000) and calculate Sx for the projection matrix ############################################################################################################################## Mortality<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/lx_00.csv",header=TRUE,sep=",") lx<-Mortality$lx2000 Lx<-array(0,c(SIZE)) for (i in 1:SIZE){Lx[i]<-.5*(lx[i]+lx[i+1])} Sx<-array(0,SIZE-1) for (i in 1:SIZE-1){Sx[i]<-(Lx[i+1]/Lx[i])} Survival<-array(0,c(SIZE,SIZE)) Survival[,]<-rbind(0,cbind(diag(Sx),0)) ############################################################################################################################## #STEP 5: Read in a generic gross migration profile (sums to one) (for instance, I just use one for Colorado, 1995-2000) ############################################################################################################################## GrossMigration<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/GrossMigrationProfile_95to00.csv",header=TRUE,sep=",") Gx<-GrossMigration$GrossMigProf ############################################################################################################################## #STEP 6: Read in data on total annual net migration ############################################################################################################################## NetMigration<-read.table(file="http://www.demog.berkeley.edu/~eddieh/AppliedDemographyToolbox/AgeSexCountyEstimates/NetMigration_90sand00s.csv",header=TRUE,sep=",") NetMigration<-as.matrix(NetMigration) NetMigration<-array(NetMigration[,2:66],c(STEPS,AREAS)) ############################################################################################################################## #STEP 7: Make arrays to hold the data for each year ############################################################################################################################## K20<-K19<-K18<-K17<-K16<-K15<-K14<-K13<-K12<-K11<-K10<-K9<-K8<-K7<-K6<-K5<-K4<-K3<-K2<-K1<-array(0,c(SIZE,AREAS)) ############################################################################################################################## #STEP 8: Simply age the population one year forward (including rates of survival), add births and repeat ############################################################################################################################## Births0<-array(0,c(SIZE,AREAS)) Births0[1,]<-Births[1,] for(i in 1:AREAS){K1[,i]<-(Survival%*%KBase1[,i])+(Births0[,i])*fab} Births1<-array(0,c(SIZE,AREAS)) Births1[1,]<-Births[2,] for(i in 1:AREAS){K2[,i]<-(Survival%*%K1[,i])+(Births1[,i])*fab} Births2<-array(0,c(SIZE,AREAS)) Births2[1,]<-Births[3,] for(i in 1:AREAS){K3[,i]<-(Survival%*%K2[,i])+(Births2[,i])*fab} Births3<-array(0,c(SIZE,AREAS)) Births3[1,]<-Births[4,] for(i in 1:AREAS){K4[,i]<-(Survival%*%K3[,i])+(Births3[,i])*fab} Births4<-array(0,c(SIZE,AREAS)) Births4[1,]<-Births[5,] for(i in 1:AREAS){K5[,i]<-(Survival%*%K4[,i])+(Births4[,i])*fab} Births5<-array(0,c(SIZE,AREAS)) Births5[1,]<-Births[6,] for(i in 1:AREAS){K6[,i]<-(Survival%*%K5[,i])+(Births5[,i])*fab} Births6<-array(0,c(SIZE,AREAS)) Births6[1,]<-Births[7,] for(i in 1:AREAS){K7[,i]<-(Survival%*%K6[,i])+(Births6[,i])*fab} Births7<-array(0,c(SIZE,AREAS)) Births7[1,]<-Births[8,] for(i in 1:AREAS){K8[,i]<-(Survival%*%K7[,i])+(Births7[,i])*fab} Births8<-array(0,c(SIZE,AREAS)) Births8[1,]<-Births[9,] for(i in 1:AREAS){K9[,i]<-(Survival%*%K8[,i])+(Births8[,i])*fab} Births9<-array(0,c(SIZE,AREAS)) Births9[1,]<-Births[10,] for(i in 1:AREAS){K10[,i]<-(Survival%*%K9[,i])+(Births9[,i])*fab} ############################################################################################################################## #STEP 9: Calculate net migration by age (simply the second census population minus the 10th projection step) ############################################################################################################################## Nx<-KBase2-K10 ############################################################################################################################## #STEP 10: Standardize the net migration by proportionally adjusting it with the generic gross migration profile ############################################################################################################################## NxStandard<-Nx for(i in 1:AREAS){NxStandard[,i]<-(Nx[,i])-Gx*sum(Nx[,i])} ############################################################################################################################## #STEP 11: Apply the net migration profile to each intercensal year by adding the sum of net migration through the specified intercensal year #***multiplied by a proportion of net migration (naive .5 is used on this example, but is not recommended for all cases) for the sub-population (males)***, #multiplied by Gx plus Nxstandard times n/10 (the standard profile is interpolated) to Kx[t+n]temp # #Note in a previous version I did the following to get the sub-population ratio: #***multiplied by the sum of the residually-calculated net migration (Nx) divided by the sum of the annual net migration data you read in (this ratio provides #a simple proportional adjustment by sex)*** #I found this creates significant problems for a lot of cases and determined that I either need to integrate the sub-groups or use something empirical. ############################################################################################################################## for(i in 1:AREAS){K1[,i]<-K1[,i]+(sum(NetMigration[1,i])*.5)*Gx+NxStandard[,i]*.1} for(i in 1:AREAS){K2[,i]<-K2[,i]+(sum(NetMigration[1:2,i])*.5)*Gx+NxStandard[,i]*.2} for(i in 1:AREAS){K3[,i]<-K3[,i]+(sum(NetMigration[1:3,i])*.5)*Gx+NxStandard[,i]*.3} for(i in 1:AREAS){K4[,i]<-K4[,i]+(sum(NetMigration[1:4,i])*.5)*Gx+NxStandard[,i]*.4} for(i in 1:AREAS){K5[,i]<-K5[,i]+(sum(NetMigration[1:5,i])*.5)*Gx+NxStandard[,i]*.5} for(i in 1:AREAS){K6[,i]<-K6[,i]+(sum(NetMigration[1:6,i])*.5)*Gx+NxStandard[,i]*.6} for(i in 1:AREAS){K7[,i]<-K7[,i]+(sum(NetMigration[1:7,i])*.5)*Gx+NxStandard[,i]*.7} for(i in 1:AREAS){K8[,i]<-K8[,i]+(sum(NetMigration[1:8,i])*.5)*Gx+NxStandard[,i]*.8} for(i in 1:AREAS){K9[,i]<-K9[,i]+(sum(NetMigration[1:9,i])*.5)*Gx+NxStandard[,i]*.9} for(i in 1:AREAS){K10[,i]<-K10[,i]+(sum(NetMigration[1:10,i])*.5)*Gx+NxStandard[,i]*1} ############################################################################################################################## #STEP 12: Repeat STEP 8 for the second decade (post-censal) ############################################################################################################################## Births10<-array(0,c(SIZE,AREAS)) Births10[1,]<-Births[11,] for(i in 1:AREAS){K11[,i]<-(Survival%*%KBase2[,i])+(Births10[,i])*fab} Births11<-array(0,c(SIZE,AREAS)) Births11[1,]<-Births[12,] for(i in 1:AREAS){K12[,i]<-(Survival%*%K11[,i])+(Births11[,i])*fab} Births12<-array(0,c(SIZE,AREAS)) Births12[1,]<-Births[13,] for(i in 1:AREAS){K13[,i]<-(Survival%*%K12[,i])+(Births12[,i])*fab} Births13<-array(0,c(SIZE,AREAS)) Births13[1,]<-Births[14,] for(i in 1:AREAS){K14[,i]<-(Survival%*%K13[,i])+(Births13[,i])*fab} Births14<-array(0,c(SIZE,AREAS)) Births14[1,]<-Births[15,] for(i in 1:AREAS){K15[,i]<-(Survival%*%K14[,i])+(Births14[,i])*fab} Births15<-array(0,c(SIZE,AREAS)) Births15[1,]<-Births[16,] for(i in 1:AREAS){K16[,i]<-(Survival%*%K15[,i])+(Births15[,i])*fab} Births16<-array(0,c(SIZE,AREAS)) Births16[1,]<-Births[17,] for(i in 1:AREAS){K17[,i]<-(Survival%*%K16[,i])+(Births16[,i])*fab} Births17<-array(0,c(SIZE,AREAS)) Births17[1,]<-Births[18,] for(i in 1:AREAS){K18[,i]<-(Survival%*%K17[,i])+(Births17[,i])*fab} Births18<-array(0,c(SIZE,AREAS)) Births18[1,]<-Births[19,] for(i in 1:AREAS){K19[,i]<-(Survival%*%K18[,i])+(Births18[,i])*fab} Births19<-array(0,c(SIZE,AREAS)) Births19[1,]<-Births[20,] for(i in 1:AREAS){K20[,i]<-(Survival%*%K19[,i])+(Births19[,i])*fab} ############################################################################################################################## #STEP 13: Repeat STEP 11 for the second decade (post-censal) ############################################################################################################################## for(i in 1:AREAS){K11[,i]<-K11[,i]+(sum(NetMigration[11,i])*.5)*Gx+NxStandard[,i]*.1} for(i in 1:AREAS){K12[,i]<-K12[,i]+(sum(NetMigration[11:12,i])*.5)*Gx+NxStandard[,i]*.2} for(i in 1:AREAS){K13[,i]<-K13[,i]+(sum(NetMigration[11:13,i])*.5)*Gx+NxStandard[,i]*.3} for(i in 1:AREAS){K14[,i]<-K14[,i]+(sum(NetMigration[11:14,i])*.5)*Gx+NxStandard[,i]*.4} for(i in 1:AREAS){K15[,i]<-K15[,i]+(sum(NetMigration[11:15,i])*.5)*Gx+NxStandard[,i]*.5} for(i in 1:AREAS){K16[,i]<-K16[,i]+(sum(NetMigration[11:16,i])*.5)*Gx+NxStandard[,i]*.6} for(i in 1:AREAS){K17[,i]<-K17[,i]+(sum(NetMigration[11:17,i])*.5)*Gx+NxStandard[,i]*.7} for(i in 1:AREAS){K18[,i]<-K18[,i]+(sum(NetMigration[11:18,i])*.5)*Gx+NxStandard[,i]*.8} for(i in 1:AREAS){K19[,i]<-K19[,i]+(sum(NetMigration[11:19,i])*.5)*Gx+NxStandard[,i]*.9} for(i in 1:AREAS){K20[,i]<-K20[,i]+(sum(NetMigration[11:20,i])*.5)*Gx+NxStandard[,i]*1} ############################################################################################################################## #STEP 14: Replace any negative numbers with zeroes (if/when you adjust the estimates up to other estimates, be sure to make the #zeroes "flexible" (eg make them .001 so that they can proportionally adjust) ############################################################################################################################## K10[K10<0]<-K9[K9<0]<-K8[K8<0]<-K7[K7<0]<-K6[K6<0]<-K5[K5<0]<-K4[K4<0]<-K3[K3<0]<-K2[K2<0]<-K1[K1<0]<-0 K20[K20<0]<-K19[K19<0]<-K18[K18<0]<-K17[K17<0]<-K16[K16<0]<-K15[K15<0]<-K14[K14<0]<-K13[K13<0]<-K12[K12<0]<-K11[K11<0]<-0 ############################################################################################################################## #STEP 15: Do what you like with the data formatting and read it out to a csv ############################################################################################################################## K0<-KCensus1 K1<-K1+Adjust1 K2<-K2+Adjust1 K3<-K3+Adjust1 K4<-K4+Adjust1 K5<-K5+Adjust1 K6<-K6+Adjust1 K7<-K7+Adjust1 K8<-K8+Adjust1 K9<-K9+Adjust1 K10<-KCensus2 K11<-K11+Adjust2 K12<-K12+Adjust2 K13<-K13+Adjust2 K14<-K14+Adjust2 K15<-K15+Adjust2 K16<-K16+Adjust2 K17<-K17+Adjust2 K18<-K18+Adjust2 K19<-K19+Adjust2 K20<-K20+Adjust2 #write.table(K20, file="G:/###/###.csv", sep=",")