Modeling the US Population as Logistic Growth

Helmut Knaust, Department of Mathematical Sciences, UTEP, El Paso TX 79968
hknaust@utep.edu
12/30/09

The U.S. Population

Here is a table of the census data for the U.S. population from 1790-2000:

popy=Table[k,{k,1790,2000,10}];
popd={3.9,5.3,7.2,9.6,12.9,17.1,23.1,31.4,38.6,50.2,62.9,76.0,92.,105.7,122.8,131.7,150.7,179.,205.,226.5,248.7,281.4};
pop=Transpose[{popy,popd}];
TableForm[pop,TableHeadings->{None,{"Year","Population\n(millions)"}},TableAlignments->Right]

The Logistic Growth Equation

Next we compute the solution to the logistic growth equation with parameters r, K, and initial population P.

Clear[p];
eqn=p'[t]==r p[t](1-p[t]/K)

sol=DSolve[{eqn,p[0]==P},p[t],t]

p[t_]=p[t]/.sol[[1]]

Using the Method of Least Squares to Estimate the Parameters r and K

We use Newton' s Method to minimize the least squares error:

<<Optimization`UnconstrainedProblems`

ls[r_,K_,P_]=Total[(Table[p[t],{t,0,210,10}]-popd)^2]

lsmin=FindMinimum[ls[r,K,P],{{r,0.3},{K,285},{P,3.9}}, Method->"Newton"]

Dependence on "Subtle Assumptions"

We obtain a quite different result if we insist that the initial condition P = 3.9 is satisfied: The predicted population ceiling K decreases from about 442 million to 341 million!

FindMinimum[ls[r,K,3.9],{{r,0.3},{K,285}}, Method->"Newton"]

Here are the results if we only use the data from 1790 to 1990:

ls2[r_,K_,P_]=Total[(Table[p[t],{t,0,200,10}]-Drop[popd,-1])^2];

lsmin2=FindMinimum[ls2[r,K,P],{{r,0.3},{K,250},{P,3.9}}, Method->"Newton"]

Fixing the initial condition P = 3.9:

FindMinimum[ls2[r,K,3.9],{{r,0.3},{K,250}}, Method->"Newton"]

The Graph

The Least Squares Method yields the following estimates: r = .0216 and K = 442. 
Note that this means that the projected population ceiling for the U.S. is approximately 442,000,000.

p[t_]=p[t]/.sol[[1]]/.lsmin[[2]]

p1=ListPlot[pop,PlotStyle->{Red,AbsolutePointSize[7]}]

p2=Plot[p[t-1790],{t, 1790,2100},PlotStyle->Thick,BaseStyle->{Bold,14},PlotRange->{0,450},AxesOrigin->{1790,0},Epilog->{Dashed,Blue,Line[{{1790,lsmin[[2,2,2]]},{2100,lsmin[[2,2,2]]}}]},PlotLabel->"Projected U.S. Population 1790-2100",AxesLabel->{"Year","Population ((10^6))"},GridLines->Automatic,ImageSize->500]

p2a=Plot[p[t-1790],{t, 1790,2000},PlotStyle->Thick,BaseStyle->{Bold,14},PlotRange->{0,300},AxesOrigin->{1790,0},PlotLabel->"U.S. Population 1790-2000",AxesLabel->{"Year","Population ((10^6))"},GridLines->Automatic,ImageSize->500];

Show[p2a,p1]

This does not look very much like logistic growth, and indeed the inflection point of the model occurs in the year 1977:

Plot[p''[t-1790],{t,1790,2000},PlotLabel->"p''(t)",AxesOrigin->{1790,0},BaseStyle->{Bold,12},GridLines->Automatic]

The same function plotted up to the year 2100:

Show[p2,p1]