Passage 24 A #6

In this course, we have learnt,

1) An overview of the world population in the past.
2) Simple population dynamics model as exponential growth.
3) Other models in which annual growth decreases or increases with time.
4) Age structured population dynamimcs model using vector and matrix.

Today, we work on the following problem.

Problem

1) Pick up a country and describe the country' s demographic change in the past for available data. 
2) Calculate annual growth rates for each year and examine its trend (Is the annual growth rate increasing or decreasing?).
3) Predict the country population size under the assumption that the present trend continues in the future. 
4) Make a brief report about the country’s demography in past and future, mentioning the proportion of elder people.

Example Japan

Let' s choose Japan and draw its demographic change for all available data.

DateListPlot[CountryData["Japan",{"Population",All}],PlotMarkers->Automatic]

We focus on a narrower time span from 1960 to 2014.

DateListPlot[CountryData["Japan",{"Population",{1960,2014}}],PlotMarkers->Automatic]

From the demogrpahic data, we calculate annual growrh rate for each year.

dataCountry=CountryData["Japan",{"Population",{1960,2014}}]

CountryData["Japan","AdultPopulation"]

CountryData["Japan","ElderlyPopulation"]

CountryData["Japan","ChildPopulation"]

We can pick up the pouplation size from the data.

dataCountry["1990"]

dataCountry["2014"]

tableYears=Table[TextString[t],{t,1960,2014}]

List the population sizes from 1960 to 2014 (there are 55 data).

dataCountryPopSize=dataCountry[tableYears]
Length[dataCountryPopSize]

And visualize the list of the population sizes from  1960.

gPast=ListPlot[dataCountryPopSize]

We calcualte annual growth rate for each year.

dataAnnualGrowthRate={};
Do[
AppendTo[dataAnnualGrowthRate,N[(dataCountryPopSize[[i+1]]-dataCountryPopSize[[i]])/dataCountryPopSize[[i]]]],{i,1,Length[dataCountryPopSize]-1}
]

dataAnnualGrowthRate

Visualize the annual growth rate from 1960 to 2014 (The year 1960 is 1st year in the graph).

ListPlot[dataAnnualGrowthRate,Joined->True,PlotRange->All]

We focus on the recent 20 years to calcualte the trend of the annual growth rate change.

dataLast=Take[dataAnnualGrowthRate,-20]

Visualize the recent annual growth rate.

gDataAnnualGrowthRate=ListPlot[dataLast]

We fit the data with a linear function (straight line) of the year t.

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

The annual growth rate decreases by 0.000187802 every year.

gFitted=Plot[fitted,{t,0,20}]

Show[gDataAnnualGrowthRate,gFitted]

We calculate the predicted annual growth rate for  50 years in future based on the trend.

tPeriod=50;
seqGrowthRate=Table[fitted,{t,20,20+tPeriod}]

Visuzlize the predicted annual growth rate.

ListPlot[seqGrowthRate]

We calculate the population size in the future starting from the size at the year 2014.

dataCountry["2014"]

data={};
popSize=(Quantity[126225259, "people", people, "People"]);

Do[
AppendTo[data,popSize];
popSize=popSize*(1+seqGrowthRate[[i]]);,{i,1,tPeriod}
]

dataPredicted=Transpose[{Table[t,{t,56,56+tPeriod-1}],data}]

Visualize the predicted demography.

gPredicted=ListPlot[dataPredicted]

dataPast=Transpose[{Table[t,{t,1,Length[dataCountryPopSize]}],dataCountryPopSize}]

GraphicsGrid[{{gPast,gPredicted}},ImageSize->600]

dataJoined=Join[dataPast,dataPredicted];
ListPlot[dataJoined,Joined->True]

Example Germany

DateListPlot[CountryData["Germany",{"Population",All}],PlotMarkers->Automatic]

DateListPlot[CountryData["Germany",{"Population",{1960,2014}}],PlotMarkers->Automatic]

dataCountry=CountryData["Germany",{"Population",{1960,2014}}]

We can pick up the pouplation size from the data.

dataCountry["1990"]

dataCountry["2014"]

tableYears=Table[TextString[t],{t,1960,2014}]

List the population sizes from 1960 to 2014 (there are 55 data).

dataCountryPopSize=dataCountry[tableYears]
Length[dataCountryPopSize]

And visualize the list of the population sizes from  1960.

gPast=ListPlot[dataCountryPopSize]

We calcualte annual growth rate for each year.

dataAnnualGrowthRate={};
Do[
AppendTo[dataAnnualGrowthRate,N[(dataCountryPopSize[[i+1]]-dataCountryPopSize[[i]])/dataCountryPopSize[[i]]]],{i,1,Length[dataCountryPopSize]-1}
]

dataAnnualGrowthRate

Visualize the annual growth rate from 1960 to 2014 (The year 1960 is 1st year in the graph).

ListPlot[dataAnnualGrowthRate,Joined->True,PlotRange->All]

We focus on the recent 20 years to calcualte the trend of the annual growth rate change.

dataLast=Take[dataAnnualGrowthRate,-20]

Visualize the recent annual growth rate.

gDataAnnualGrowthRate=ListPlot[dataLast]

We fit the data with a linear function (straight line) of the year t.

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

gFitted=Plot[fitted,{t,0,20}]

Show[gDataAnnualGrowthRate,gFitted]

We calculate the predicted annual growth rate for  50 years in future based on the trend.

tPeriod=50;
seqGrowthRate=Table[fitted,{t,20,20+tPeriod}]

Visuzlize the predicted annual growth rate.

ListPlot[seqGrowthRate]

We calculate the population size in the future starting from the size at the year 2014.

dataCountry["2014"]

data={};
popSize=(Quantity[81625599, "people", people, "People"])

Do[
AppendTo[data,popSize];
popSize=popSize*(1+seqGrowthRate[[i]]);,{i,1,tPeriod}
]

dataPredicted=Transpose[{Table[t,{t,56,56+tPeriod-1}],data}]

Visualize the predicted demography.

gPredicted=ListPlot[dataPredicted]

dataPast=Transpose[{Table[t,{t,1,Length[dataCountryPopSize]}],dataCountryPopSize}]

GraphicsGrid[{{gPast,gPredicted}},ImageSize->600]

dataJoined=Join[dataPast,dataPredicted];
ListPlot[dataJoined,Joined->True]

Example The World

DateListPlot[CountryData["World",{"Population",All}],PlotMarkers->Automatic]

From the demogrpahic data, we calculate annual growrh rate for each year.

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

We can pick up the pouplation size from the data.

dataCountry["1990"]

dataCountry["2013"]

tableYears=Table[TextString[t],{t,1970,2013}]

List the population sizes from 1970 to 2013 (there are 44 data).

dataCountryPopSize=dataCountry[tableYears]
Length[dataCountryPopSize]

And visualize the list of the population sizes from  1970.

gPast=ListPlot[dataCountryPopSize]

We calcualte annual growth rate for each year.

dataAnnualGrowthRate={};
Do[
AppendTo[dataAnnualGrowthRate,N[(dataCountryPopSize[[i+1]]-dataCountryPopSize[[i]])/dataCountryPopSize[[i]]]],{i,1,Length[dataCountryPopSize]-1}
]

dataAnnualGrowthRate

Visualize the annual growth rate from 1970 to 2013 (The year 1970 is 1st year in the graph).

ListPlot[dataAnnualGrowthRate,Joined->True,PlotRange->All]

We focus on the recent 20 years to calcualte the trend of the annual growth rate change.

dataLast=Take[dataAnnualGrowthRate,-20]

Visualize the recent annual growth rate.

gDataAnnualGrowthRate=ListPlot[dataLast]

We fit the data with a linear function (straight line) of the year t.

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

The annual growth rate decreases by 0.000187802 every year.

gFitted=Plot[fitted,{t,0,20}]

Show[gDataAnnualGrowthRate,gFitted]

We calculate the predicted annual growth rate for  100 years in future based on the trend.

tPeriod=100;
seqGrowthRate=Table[fitted,{t,20,20+tPeriod}]

Visuzlize the predicted annual growth rate.

ListPlot[seqGrowthRate]

We calculate the population size in the future starting from the size at the year 2013.

dataCountry["2013"]

data={};
popSize=(Quantity[7.13001*10^9, "people", people, "People"]);

Do[
AppendTo[data,popSize];
popSize=popSize*(1+seqGrowthRate[[i]]);,{i,1,tPeriod}
]

dataPredicted=Transpose[{Table[t,{t,44,44+tPeriod-1}],data}]

Visualize the predicted demography.

gPredicted=ListPlot[dataPredicted]

dataPast=Transpose[{Table[t,{t,1,Length[dataCountryPopSize]}],dataCountryPopSize}]

GraphicsGrid[{{gPast,gPredicted}},ImageSize->600]

dataJoined=Join[dataPast,dataPredicted];
ListPlot[dataJoined,Joined->True]