Modeling the World Population as Logistic Growth

Helmut Knaust, Department of Mathematical Sciences, UTEP, El Paso TX 79968
hknaust@utep.edu
12/30/2009; last edit 11/2/2011

The World Population

Here is a table for the world population from 1950-2005 and its graph:

popy=Table[k,{k,1950,2005,5}];
popd={2.519,2.756,2.982,3.335,3.692,4.068,4.435,4.831,5.263,5.674,6.070,6.454};
pop=Transpose[{popy,popd}];
TableForm[pop,TableHeadings->{None,{"Year","Population((10^9))"}},TableAlignments->Right]
p1=ListPlot[pop,PlotStyle->{Red,AbsolutePointSize[7]},BaseStyle->{Bold,14},PlotRange->{0,7},AxesOrigin->{1950,0},PlotLabel->"World Population 1950-2005",AxesLabel->{"Year","Population ((10^9))"},GridLines->Automatic,ImageSize->500]

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)

A typical solution to a logistic growth equation:

Plot[10 Exp[.2 t]/(400+Exp[.2t]),{t,10,55}]

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.,55,5}]-popd)^2]

lsmin=FindMinimum[ls[r,K,P],{{r,0.2},{K,9.0},{P,2.519}}, Method->"Newton"]

The Graph

The Least Squares Method yields the following estimates: r = .0271 and K = 12.361. 
This means that our models predicts the world population ceiling to be at approximately 12.4 billion.

p[t_]=p[t]/.sol[[1]]/.lsmin[[2]]/.P->2.519

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

p2=Plot[p[t-1950],{t, 1900,2100},PlotStyle->Thick,BaseStyle->{Bold,14},PlotRange->{0,13},AxesOrigin->{1900,0},Epilog->{Dashed,Blue,Line[{{1900,lsmin[[2,2,2]]},{2100,lsmin[[2,2,2]]}}]},PlotLabel->"Projected World Population 1900-2100",AxesLabel->{"Year","Population ((10^9))"},GridLines->Automatic,ImageSize->500];

p2a=Plot[p[t-1950],{t, 1950,2005},PlotStyle->Thick,BaseStyle->{Bold,14},PlotRange->{0,7},AxesOrigin->{1950,0},PlotLabel->"World Population 1950-2005",AxesLabel->{"Year","Population ((10^9))"},GridLines->Automatic,ImageSize->500];

Show[p2a,p1]

The inflection point of the model occurs in 2001:

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

The same function plotted up to the year 2100:

Show[p2,p1]

Here are the current United Nations projections:

Source: http://en.wikipedia.org/wiki/File:World-Population-1800-2100.png, retrieved 12/30/09.