Passage 24 A #4

Population growth when annual growth rate is not a constant

Let r be annual growth rate.

	(Subscript[N, t+1])=r (Subscript[N, t])

If r is a constant and r > 1, the population exponential increases. If 0 < r < 1, it exponentially decreases to zero. 

But annual growth rate r may NOT be a constant. It likely changes with time; economy, social system,etc. would influence it. How does the population change when annual growth rate changes with time?

In this course, we numerically simulate population dynamics for 1) Exponential growth (annual growth rate being constant), 2) Annual growth rate linearly decreases with time, 3) It linearly increases with time.

Annual growth rate is a constant - exponential model

tPeriod=50

The population increases by a constant percentage every year.

seqGrowthRate0=Table[1.02,{t,tPeriod}]

ListPlot[seqGrowthRate0,AxesLabel->{"t","r"}]

data0={};
popSize=1;

Do[
AppendTo[data0,popSize];
popSize=popSize*seqGrowthRate0[[i]];,{i,1,tPeriod}
]

data0

g0=ListPlot[data0,AxesLabel->{"t","N_t"}]

gLog0=ListLogPlot[data0,AxesLabel->{"t","N_t"}]

Log[2]/Log[1.02]

Annual growth rate linearly decreases with time

tPeriod=50

seqGrowthRate1=Table[1+0.02-0.001(t-1),{t,tPeriod}]

ListPlot[seqGrowthRate1,AxesLabel->{"t","r"}]

data1={};
popSize=1;

Do[
AppendTo[data1,popSize];
popSize=popSize*seqGrowthRate1[[i]];,{i,1,tPeriod}
]

data1

g1=ListPlot[data1,AxesLabel->{"t","N_t"}]

gLog1=ListLogPlot[data1,AxesLabel->{"t","N_t"}]

Annual growth rate linearly increases with time

tPeriod=50

seqGrowthRate2=Table[1.02+0.001(t-1),{t,tPeriod}]

ListPlot[seqGrowthRate2,AxesLabel->{"t","r"}]

data2={};
popSize=1;

Do[
AppendTo[data2,popSize];
popSize=popSize*seqGrowthRate2[[i]];,{i,1,tPeriod}
]

data2

g2=ListPlot[data2,AxesLabel->{"t","N_t"}]

gLog2=ListLogPlot[data2,AxesLabel->{"t","N_t"}]

Let compare the three cases

Show[g0,g1,g2,PlotRange->All]

Show[gLog0,gLog1,gLog2,PlotRange->All]

Question

What factors can influence the annual growth rate “r”?

Assume various scenarios about annual growth rate that changes with time and simulate it.

For example, annual growth rate of the world population was 1.07% in 2015. If it linearly decreases by e.g., 0.02% every year, how does the world population grow in future? What is the maximal world population in this case?

Annual growth rate of Japanese population was - 0.17 % in 2015. If it linearly increases by e.g., 0.02 % every year, when does Japanese population start to increase? What is the minimal Japanese population in this case?

What else would be interesting? Simulate them.

Example: How the world population has been changing in the past decades

data=CountryData["World",{"Population",All}]

We have data from 1950 to 2019.

DateListPlot[data]

DateListLogPlot[data]

In logarithmic scale, the world population seemingly has been exponentially increasing with two phases; one until around 1990 and the another after 1990.
Calculate "difference" between years, i.e., how many people had increased in a year.

dataDiff=Differences[data]

DateListPlot[dataDiff]

Calculate the annual growth rate in percentage, i.e., relative growth.

annGrowthRate=dataDiff/data 100

gAnnGrowthRate=DateListPlot[annGrowthRate]

annGrowthRate["1971"]//N

annGrowthRate["1990"]//N

annGrowthRate["2019"]//N

(annGrowthRate["1971"]-annGrowthRate["2019"])/(2019-1971)//N

1971 : 2.001 %
2019: 1.079%
0.0193% decrease per year.

Annual growth rate of the world is constantly decreasing since around 1990. If this trend continues, how large will be the world population in future?

fitted=Fit[annGrowthRate,{1,t},t]

gFitted=Plot[fitted,{t,AbsoluteTime[{1950}],AbsoluteTime[{2019}]}]

Show[gAnnGrowthRate,gFitted]

tDiff=AbsoluteTime[{2019}]-AbsoluteTime[{2000}]

Coefficient[fitted,t]

Coefficient[fitted,t]tDiff

Example: How Japan’s population has been changing in the past decades

data=CountryData["Japan",{"Population",{1950,2019}}]

DateListPlot[data]

DateListLogPlot[data]

Calculate "difference" between years, i.e., how many people had increased in a year.

dataDiff=Differences[data]

DateListPlot[dataDiff]

Calculate the annual growth rate in percentage, i.e., relative growth.

annGrowthRate=dataDiff/data 100

gAnnGrowthRate=DateListPlot[annGrowthRate]

annGrowthRate["1972"]//N

annGrowthRate["1990"]//N

annGrowthRate["2019"]//N

(annGrowthRate["1972"]-annGrowthRate["2019"])/(2019-1972)//N

1972 : 1.43451 %
2019: -0.2695%
0.03626% decrease per year.

Annual growth rate of Japan is constantly decreasing since around 1990. If this trend continues, how large will be the population in future?

fitted=Fit[annGrowthRate,{1,t},t]

gFitted=Plot[fitted,{t,AbsoluteTime[{1950}],AbsoluteTime[{2019}]}]

Show[gAnnGrowthRate,gFitted]

tDiff=AbsoluteTime[{2019}]-AbsoluteTime[{2000}]

Coefficient[fitted,t]

Coefficient[fitted,t]tDiff

Example: How France population has been changing in the past decades

data=CountryData["France",{"Population",{1950,2019}}]

DateListPlot[data]

DateListLogPlot[data]

Calculate "difference" between years, i.e., how many people had increased in a year.

dataDiff=Differences[data]

DateListPlot[dataDiff]

Calculate the annual growth rate in percentage, i.e., relative growth.

annGrowthRate=dataDiff/data 100

gAnnGrowthRate=DateListPlot[annGrowthRate]

annGrowthRate["1972"]//N

annGrowthRate["1990"]//N

annGrowthRate["2019"]//N

(annGrowthRate["1972"]-annGrowthRate["2019"])/(2019-1972)//N

1972 : 0.796341 %
2019: 0.213756%
0.0123954% decrease per year.

Annual growth rate of France is constantly decreasing.  If this trend continues, how large will be the population in future?

fitted=Fit[annGrowthRate,{1,t},t]

gFitted=Plot[fitted,{t,AbsoluteTime[{1950}],AbsoluteTime[{2019}]}]

Show[gAnnGrowthRate,gFitted]

tDiff=AbsoluteTime[{2019}]-AbsoluteTime[{2000}]

Coefficient[fitted,t]

Coefficient[fitted,t]tDiff

Example: How Thailand population has been changing in the past decades

data=CountryData["Thailand",{"Population",{1950,2019}}]

DateListPlot[data]

DateListLogPlot[data]

Calculate "difference" between years, i.e., how many people had increased in a year.

dataDiff=Differences[data]

DateListPlot[dataDiff]

Calculate the annual growth rate in percentage, i.e., relative growth.

annGrowthRate=dataDiff/data 100

gAnnGrowthRate=DateListPlot[annGrowthRate]

annGrowthRate["1965"]//N

annGrowthRate["1990"]//N

annGrowthRate["2019"]//N

(annGrowthRate["1965"]-annGrowthRate["2019"])/(2019-1965)//N

1965 : 2.95865 %
2019: 0.283124%
0.0495467% decrease per year.

Annual growth rate of Thailand is constantly decreasing after around 1998.  If this trend continues, how large will be the population in future?

fitted=Fit[annGrowthRate,{1,t},t]

gFitted=Plot[fitted,{t,AbsoluteTime[{1950}],AbsoluteTime[{2019}]}]

Show[gAnnGrowthRate,gFitted]

tDiff=AbsoluteTime[{2019}]-AbsoluteTime[{2000}]

Coefficient[fitted,t]

Coefficient[fitted,t]tDiff

Obsolete

t=0;
fn[x_,r0_,r1_]:=Module[{growthRate,tmp},
growthRate=r0+r1 t;
t++;
tmp=x growthRate;
Return[tmp];
]

fn[1,1.2,0.1]

t=0;
data=NestList[fn[#,1.2,-0.01]&,1,20]

ListPlot[data]

ListLogPlot[data]