(*********************************************************************** Mathematica-Compatible Notebook This notebook can be used on any computer system with Mathematica 4.0, MathReader 4.0, or any compatible application. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. ***********************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 25765, 901]*) (*NotebookOutlinePosition[ 26495, 927]*) (* CellTagsIndexPosition[ 26451, 923]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell["Population Models", "Title", CellFrame->True, TextAlignment->Center, Background->RGBColor[0, 1, 0]], Cell["\<\ This notebook is by Steven Amgott. Please send any questions or comments to \ samgott1@swarthmore.edu. Feel free to use and distribute this notebook, but \ keep this author information in any copy you use or distribute.\ \>", "SmallText"], Cell[TextData[{ "In any input cell containing ", StyleBox["xxx", FontColor->RGBColor[1, 0, 1]], " , you must replace it with your input before evaluating the cell. In \ general, anything in ", StyleBox["magenta", FontColor->RGBColor[1, 0, 1]], " is something you can, and possibly should, change." }], "Text"], Cell["\<\ The following cell is an initialization cell which will be automatically \ evaluated, provided you answer \"Yes\" to the initialization prompt. If you \ do not, you will need to evaluate it manually before using some of the \ specialized graphics commands in the sections below.\ \>", "Text"], Cell[BoxData[ \(Needs["\"]\)], "Input", InitializationCell->True, AspectRatioFixed->True], Cell[CellGroupData[{ Cell["The Population of Houston", "Section"], Cell["\<\ The table below gives the population of Houston, Texas, from U.S. Census \ data.\ \>", "Text"], Cell["\<\ Census Date\t\tPopulation 1850\t\t\t18,632 1860\t\t\t35,441 1870\t\t\t48,986 1880\t\t\t71,316 1890\t\t\t86,224 1900\t\t\t134,600 1910\t\t\t185,654 1920\t\t\t272,475 1930\t\t\t455,570 1940\t\t\t646,869 1950\t\t\t947,500 1960\t\t\t1,430,394 1970\t\t\t1,999,316 1980\t\t\t2,905,344\ \>", "Text"], Cell[TextData[{ "Here are three lists of data that we obtain from the table. ", StyleBox["Make sure to evaluate input cells below", FontColor->RGBColor[1, 0, 1]], "." }], "Text"], Cell[BoxData[ \(years = {1850, 1860, 1870, 1880, 1890, 1900, 1910, 1920, 1930, 1940, 1950, 1960, 1970, 1980}\)], "Input"], Cell[BoxData[ \(population = {18632, 35441, 48986, 71316, 86224, 134600, 185654, 272475, 455570, 646896, 947500, 1430394, 1999316, 2905344}\)], "Input"], Cell[BoxData[ \(yearPop = {{1850, 18632}, {1860, 35441}, {1870, 48986}, {1880, 71316}, { 1890, 86224}, {1900, 134600}, {1910, 185654}, {1920, 272475}, { 1930, 455570}, {1940, 646896}, {1950, 947500}, {1960, 1430394}, { 1970, 1999316}, {1980, 2905344}}\)], "Input"], Cell["Let's see if an exponential model is appropriate.", "Text"], Cell[BoxData[ \(\(LogListPlot[yearPop, PlotStyle \[Rule] PointSize[0.015]]; \)\)], "Input"], Cell["\<\ Looking at the semilog plot of the data, there seems to be a roughly linear \ relationship between the natural log of the population and the year. This \ indicates that population is approximately an exponential function of the \ year.\ \>", "Text"], Cell["We would like to find a formula for the function.", "Text"], Cell["\<\ We begin by trying to find an equation for the (approximate) line fitting the \ semilog plot.\ \>", "Text"], Cell[BoxData[ \(delta[data_] := Drop[data, 1] - Drop[data, \(-1\)]\)], "Input"], Cell[BoxData[ \(delta[N[Log[population]]]/delta[years]\)], "Input"], Cell["\<\ Although these slopes are not all the same, many are in the 0.03 to 0.04 \ range. I will take an average of them.\ \>", "Text"], Cell[BoxData[ \(\((Plus@@%)\)/\((Length[years] - 1)\)\)], "Input"], Cell["\<\ There are many choices we could make for the slope. I will use 0.039 here. \ We need a y-intercept.\ \>", "Text"], Cell[BoxData[ \(Log[population] - 0.039\ \ years\)], "Input"], Cell["\<\ Although these are not all the same, many are in the -62.3 to -62.1 range. I \ will take an average of them.\ \>", "Text"], Cell[BoxData[ \(\((Plus@@%)\)/Length[years]\)], "Input"], Cell["\<\ A guess for the equation of the line is Log[population] = 0.038 years - \ 62.27.\ \>", "Text"], Cell["Let's graph the line against the data.", "Text"], Cell[BoxData[ \(a = \(slope = 0.039\); \nb = \(yIntercept = \(-62.27\)\); \n logPlot = ListPlot[Transpose[{years, Log[population]}], PlotStyle \[Rule] PointSize[0.015]]; \n linePlot = Plot[a\ t + b, Evaluate[Flatten[{t, First[PlotRange[logPlot]]}]], PlotStyle \[Rule] {{AbsoluteThickness[2]}}, GridLines \[Rule] Automatic]; \n Show[logPlot, linePlot, Ticks \[Rule] Automatic, AxesLabel \[Rule] {"\< Log[p]\>", "\"}]; \)], "Input", AspectRatioFixed->True], Cell[" We can exponentiate to get a formula for the population.", "Text"], Cell[BoxData[ \(pop[t_] = \[ExponentialE]\^b\ \[ExponentialE]\^\(a\ t\)\)], "Input"], Cell["A graphical check:", "Text"], Cell[BoxData[ \(popPlot = ListPlot[yearPop]; \nfitPlot = Plot[pop[t], {t, 1850, 1980}]; \nShow[popPlot, fitPlot]; \)], "Input"], Cell["\<\ From the last graph, I can accept the fit function as a plausible one. We \ can also calculate the percentage errors in our fit using the next cell.\ \>", "Text"], Cell[BoxData[ \(\(pop[years] - population\)\/population\)], "Input"], Cell[BoxData[ \(Plus@@Abs[%]/Length[population]\)], "Input"], Cell["\<\ The average percentage error is about 7%. That's probably not too bad.\ \>", "Text"], Cell[TextData[{ "The population doubles in the time t with ", Cell[BoxData[ \(TraditionalForm\`\[ExponentialE]\^\(0.038\ t\)\)]], "=2. We can solve for this using ", StyleBox["Mathematica", FontSlant->"Italic"], "." }], "Text"], Cell[BoxData[ \(Solve[\[ExponentialE]\^\(0.038\ t\) == 2, t]\)], "Input"], Cell["\<\ A quick glance at the population data indicates a doubling in less than 20 \ years, so this seems reasonable.\ \>", "Text"], Cell["\<\ Let's use our model to estimate Houston's population in the year 2000 and \ also in the year 2050.\ \>", "Text"], Cell[BoxData[ \(pop[{2000, 2050}]\)], "Input"], Cell["\<\ Somehow, I doubt this will happen (at least in the year 2050). The \ population of Houston would be about 42 million in 2050, which is quite \ unreasonable. Even the year 2000 figure (6.3 million) seems high. \ (Currently, the Houston area has a population of about 4,518,400, according \ to one site on the World Wide Web. This counts the city and surrounding \ area, not just the city proper, which has a population of about 1.6 million.)\ \ \>", "Text"] }, Closed]], Cell[CellGroupData[{ Cell["The U. S. Population", "Section"], Cell[CellGroupData[{ Cell["The data and a plot.", "Subsection"], Cell[TextData[{ "The next cell contains values for the world population (in millions) from \ 1790 to 1990. ", StyleBox["Make sure to evaluate the input cells below.", FontColor->RGBColor[1, 0, 1]] }], "Text"], Cell[BoxData[ \(\(usData = {{1790, 3.9}, {1800, 5.3}, {1810, 7.2}, {1820, 9.6}, {1830, 12.9}, {1840, 17.1}, {1850, 23.1}, {1860, 31.4}, {1870, 38.6}, { 1880, 50.2}, {1890, 62.9}, {1900, 76.0}, {1910, 92.0}, {1920, 105.7}, {1930, 122.8}, {1940, 131.7}, {1950, 150.7}, {1960, 179.3}, {1970, 203.3}, {1980, 226.5}, {1990, 248.7}}; \)\)], "Input",\ CellMargins->{{17, Inherited}, {Inherited, Inherited}}, CellLabelMargins->{{30, Inherited}, {Inherited, Inherited}}, AspectRatioFixed->False], Cell[TextData[{ "We can have ", StyleBox["Mathematica", FontSlant->"Italic"], " draw a plot of the data." }], "Text"], Cell[BoxData[ \(\(usPopPlot = ListPlot[usData, AxesLabel \[Rule] {"\", "\

"}, PlotStyle \[Rule] PointSize[0.015]]; \)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Does an exponential model seem to work?", "Subsection"], Cell["Let's see if this seems exponential.", "Text"], Cell[BoxData[ \(\(LogListPlot[usData, AxesLabel \[Rule] {"\", "\

"}, PlotStyle \[Rule] PointSize[0.015]];\)\)], "Input"], Cell["What do you think?", "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Does the logistic model work?", "Subsection"], Cell["\<\ We have another model, namely the logistic model, which allows for an \ eventually slowing population growth. One way to write this model is:\ \>", "Text"], Cell[TextData[{ StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" = k P (1 - ", FontWeight->"Bold"], Cell[BoxData[ FormBox[ FractionBox[ StyleBox["P", FontWeight->"Bold", FontSlant->"Plain"], StyleBox["L", FontWeight->"Bold", FontSlant->"Plain"]], TraditionalForm]]], StyleBox[")", FontWeight->"Bold"] }], "Text", Evaluatable->False, TextAlignment->Center, TextJustification->0], Cell[TextData[{ "This model says that ", StyleBox["(", FontWeight->"Bold"], StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" )", FontWeight->"Bold"], " ", StyleBox["/ P", FontWeight->"Bold"], " is a linear function of ", StyleBox["P", FontWeight->"Bold"], ". If we want to see if such a model fits the data, we could approximate \ ", StyleBox["(", FontWeight->"Bold"], StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" )", FontWeight->"Bold"], " ", StyleBox["/ P", FontWeight->"Bold"], " and draw a plot of it against ", StyleBox["P", FontWeight->"Bold"], ". We will use \"symmetric difference quotients\" to approximate ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], " . This is done in the next few cells." }], "Text"], Cell[BoxData[{ \(popValues = \(Transpose[usData]\)[\([2]\)]\), \(years = \(Transpose[usData]\)[\([1]\)]\)}], "Input"], Cell[BoxData[ \(sdqValues = \(Drop[popValues, 2] - Drop[popValues, \(-2\)]\)\/20 // N\)], "Input"], Cell[BoxData[ \(derivData = Transpose[{Drop[Drop[popValues, 1], \(-1\)], sdqValues\/Drop[Drop[popValues, 1], \(-1\)]}]\)], "Input"], Cell[TextData[{ "Now that we have the (", StyleBox["P", FontWeight->"Bold"], ", ", StyleBox["(", FontWeight->"Bold"], StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" )", FontWeight->"Bold"], " ", StyleBox["/ P", FontWeight->"Bold"], ") data, we draw a plot, and see if it is approximately a straight line." }], "Text"], Cell[BoxData[ \(\(derivPlot = ListPlot[derivData, AxesLabel \[Rule] {"\< p (millions)\>", "\<(dp/dt)/p\>"}, PlotStyle \[Rule] PointSize[0.015], PlotRange \[Rule] {0, .04}]; \)\)], "Input"], Cell["\<\ This does not look too good after 1940. Let's try for a model up to 1940.\ \>", "Text"], Cell[BoxData[ \(\(derivPlot2 = ListPlot[derivData, AxesLabel \[Rule] {"\< p (millions)\>", "\<(dp/dt)/p\>"}, PlotStyle \[Rule] PointSize[0.015], PlotRange \[Rule] {{0, 130}, {0, .04}}]; \)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Finding the parameter values from the data.", "Subsection"], Cell[TextData[{ "We can once again try to fit a line to ", StyleBox["(", FontWeight->"Bold"], StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" )", FontWeight->"Bold"], " ", StyleBox["/ P", FontWeight->"Bold"], " as a function of ", StyleBox["P", FontWeight->"Bold"], ".. This time I will skip all the work, and just show a reasonable fit." }], "Text"], Cell[BoxData[ \(a = \(slope = \(- .000170\)\); \nb = \(yIntercept = 0.0318\); \n linePlot = Plot[a\ t + b, Evaluate[Flatten[{t, First[PlotRange[derivPlot2]]}]], PlotStyle \[Rule] {{AbsoluteThickness[2]}}, GridLines \[Rule] Automatic, DisplayFunction \[Rule] Identity]; \n Show[derivPlot2, linePlot, Ticks \[Rule] Automatic, AxesLabel \[Rule] {"\< Log[p]\>", "\"}]; \)], "Input", AspectRatioFixed->True], Cell["Multiplying through by P, we get", "Text"], Cell[TextData[{ StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" = P (.0318 - .000170 P)", FontWeight->"Bold"] }], "Text", Evaluatable->False, TextAlignment->Center, TextJustification->0], Cell["\<\ Factoring out .0318, we get k = .0318 and L = 187.059. This predicts a \ limiting population of 187.059 million. Here is a plot of the solution of \ the differential equation against the original data.\ \>", "Text"], Cell[BoxData[ \(solPlot = Plot[187\/\(1 + 47\ \[ExponentialE]\^\(\(- .0318\)\ \((t - 1790)\)\)\), {t, 1790, 1940}]; \nShow[solPlot, usPopPlot]; \)], "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["World Population", "Section"], Cell[CellGroupData[{ Cell["The data and a plot.", "Subsection"], Cell[TextData[{ "The next cell contains values for the world population (in millions) for \ 14 different years. ", StyleBox["Once again, make sure to evaluate the input cells below.", FontColor->RGBColor[1, 0, 1]] }], "Text"], Cell[BoxData[ \(\(worldData = {{1000, 200}, {1650, 545}, {1750, 728}, {1800, 906}, {1850, 1171}, {1900, 1608}, {1920, 1834}, {1930, 2070}, {1940, 2295}, {1950, 2517}, {1960, 3005}, {1976, 4000}, {1987, 5000}, {1991, 5400}, {1999, 6000}};\)\)], "Input", CellMargins->{{17, Inherited}, {Inherited, Inherited}}, CellLabelMargins->{{30, Inherited}, {Inherited, Inherited}}, AspectRatioFixed->False], Cell[TextData[{ "We can have ", StyleBox["Mathematica", FontSlant->"Italic"], " draw a plot of the data." }], "Text"], Cell[BoxData[ \(\(wPopPlot = ListPlot[worldData, AxesLabel \[Rule] {"\", "\

"}, PlotStyle \[Rule] PointSize[0.015]]; \)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Does an exponential model seem to work?", "Subsection"], Cell["\<\ Does it appear to be exponential? If so, a semilog plot should be a straight \ line.\ \>", "Text"], Cell[BoxData[ \(\(LogListPlot[worldData, AxesLabel \[Rule] {"\", "\

"}, PlotStyle \[Rule] PointSize[0.015]]; \)\)], "Input", AspectRatioFixed->True] }, Closed]], Cell[CellGroupData[{ Cell["Does the coalition model work?", "Subsection"], Cell["\<\ We have another model, namely the coalition model, which allows for faster \ than exponential growth. One way to write this model is:\ \>", "Text"], Cell[TextData[{ StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" = r P", FontWeight->"Bold"], StyleBox["1+k", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}] }], "Text", Evaluatable->False, TextAlignment->Center, AspectRatioFixed->True], Cell[TextData[{ "This model says that ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[" ", FontWeight->"Bold"], " is a power function of ", StyleBox["P", FontWeight->"Bold"], ". If we want to see if such a model fits the data, we could approximate ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], " and draw a log-log plot of it against ", StyleBox["P", FontWeight->"Bold"], ". We will use \"symmetric difference quotients\" to approximate ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], " . This is done in the next few cells." }], "Text"], Cell[BoxData[{ \(popValues = \(Transpose[worldData]\)[\([2]\)]\), \(years = \(Transpose[worldData]\)[\([1]\)]\)}], "Input"], Cell[BoxData[ \(sdqValues = \(Drop[popValues, \(-2\)] - Drop[popValues, 2]\)\/\(Drop[years, \(-2\)] - Drop[years, 2]\) // N\)], "Input"], Cell[BoxData[ \(derivData = Transpose[{Drop[Drop[popValues, 1], \(-1\)], sdqValues}]\)], "Input"], Cell[TextData[{ "Now that we have the (", StyleBox["P", FontWeight->"Bold"], ", ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], ") data, we draw a log-log plot, and see if it is approximately a straight \ line." }], "Text"], Cell[BoxData[ \(\(logLogDerivPlot = LogLogListPlot[derivData, AxesLabel \[Rule] {"\< p (millions)\>", "\"}, PlotStyle \[Rule] PointSize[0.015]]; \)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Finding the parameter values from the data.", "Subsection"], Cell[TextData[{ StyleBox["Mathematica", FontSlant->"Italic"], " can find least-squares fits to data." }], "Text"], Cell[BoxData[ \(Fit[Log[10, derivData] // N, {1, x}, x]\)], "Input"], Cell[TextData[{ "Let's graph the line against the (", StyleBox["P", FontWeight->"Bold"], ", ", StyleBox["dP", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["dt", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], ") data." }], "Text"], Cell[BoxData[ \(a = \(slope = 2.14\); \nb = \(yIntercept = \(-5.79\)\); \n linePlot = Plot[a\ t + b, Evaluate[Flatten[{t, First[PlotRange[logLogDerivPlot]]}]], PlotStyle \[Rule] {{AbsoluteThickness[2]}}, GridLines \[Rule] Automatic, DisplayFunction \[Rule] Identity]; \n Show[logLogDerivPlot, linePlot, Ticks \[Rule] Automatic, AxesLabel \[Rule] {"\< Log[p]\>", "\"}]; \)], "Input", AspectRatioFixed->True], Cell["\<\ Since this slope and estimate came from the log-log plot, the original \ parameters are\ \>", "Text"], Cell[BoxData[{ \(r = 10\^b\), \(k = a - 1\)}], "Input"], Cell["\<\ Let's plot the estimated derivatives against the model with these parameters. \ This time we will do a regular plot rather than a log-log plot.\ \>", "Text"], Cell[BoxData[ \(Clear[dpdt, p]; \ndpdt[p_] = r\ p\^\(1 + k\); \n derivPlot = ListPlot[derivData, AxesLabel \[Rule] {"\< p (millions)\>", "\"}, PlotStyle \[Rule] PointSize[0.015]]; \n dpdtPlot = Plot[dpdt[p], {p, 0, 5000}, AxesLabel \[Rule] {"\< p (millions)\>", "\"}, PlotStyle \[Rule] {{AbsoluteThickness[2]}}]; \n Show[derivPlot, dpdtPlot]; \)], "Input", CellFrame->False, AspectRatioFixed->False, Background->None] }, Closed]], Cell[CellGroupData[{ Cell["Finding \"Doomsday.\"", "Subsection"], Cell["\<\ Recall that the solution to the coalition model differential equation can be \ written in the form\ \>", "Text"], Cell[TextData[{ StyleBox["P = ", FontWeight->"Bold"], StyleBox["[", FontSize->18, FontWeight->"Bold"], StyleBox[" ", FontWeight->"Bold"], StyleBox["1", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}], StyleBox["/", FontWeight->"Bold"], StyleBox["kr(T", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox["-", FontFamily->"Courier", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox["t)", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox["]", FontSize->18, FontWeight->"Bold"], StyleBox["1/k", FontWeight->"Bold", FontVariations->{"CompatibilityType"->"Superscript"}] }], "Text", Evaluatable->False, TextAlignment->Center, AspectRatioFixed->True], Cell[TextData[{ "where ", StyleBox["T", FontWeight->"Bold"], " is \"doomsday,\" the year when the population approaches infinity. Since \ ", StyleBox["P", FontWeight->"Bold"], " is a power function of (", StyleBox["T", FontWeight->"Bold"], "-t), a log-log plot with the correct value of ", StyleBox["T", FontWeight->"Bold"], " should be approximately a line. We can guess at a value of ", StyleBox["T", FontWeight->"Bold"], ", and draw a log-log plot of the population values against (", StyleBox["T", FontWeight->"Bold"], "-t). (If you do not want to experiment, a cell grouped with the one below \ contains a possible value for T.)" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[{ RowBox[{ RowBox[{"T", "=", StyleBox["xxx", FontColor->RGBColor[1, 0, 1]]}], ";"}], "\n", \(LogLogListPlot[Transpose[{T - years, popValues}], AxesLabel \[Rule] {"\< T-t\>", "\"}, PlotStyle \[Rule] PointSize[0.015]];\)}], "Input"], Cell[TextData[{ "A ", StyleBox["T", FontWeight->"Bold"], " that works is about 2027." }], "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Comparing the model to the data.", "Subsection"], Cell[TextData[{ "We can now create our model function from ", StyleBox["k", FontWeight->"Bold"], ", ", StyleBox["r", FontWeight->"Bold"], ", and ", StyleBox["T", FontWeight->"Bold"], " above." }], "Text"], Cell[BoxData[{ \(\(Clear[pModel]; \)\), \(\(pModel[t_] := N[\((k\ r\ \((T - t)\))\)\^\(\(-1. \)/k\)]; \)\)}], "Input", AspectRatioFixed->False], Cell["Here is a plot of our model.", "Text"], Cell[BoxData[ \(\(modelPlot = Plot[pModel[t], Evaluate[Flatten[{t, First[PlotRange[wPopPlot]]}]], PlotStyle \[Rule] {{AbsoluteThickness[2]}}]; \)\)], "Input"], Cell["We can superimpose it on our original data plot.", "Text"], Cell[BoxData[ \(\(Show[modelPlot, wPopPlot, PlotRange -> {{1400, 2000}, {0, 6000}}]; \)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Updating the data.", "Subsection"], Cell["\<\ You may wish to go back to the cell defining worldData (in The Data and a \ Plot subsection), and update the population data to whatever is the best \ current estimates of world populations. In particular, the world's \ population is estimated to break six billion in 1999. You can then \ re-evaluate all the cells in the World Population section, making all \ necessary changes. Does the model seem more or less valid with the updated \ data? \ \>", "Text"] }, Closed]] }, Closed]] }, Open ]] }, FrontEndVersion->"4.0 for Microsoft Windows", ScreenRectangle->{{0, 1024}, {0, 720}}, AutoGeneratedPackage->None, WindowToolbars->"EditBar", CellGrouping->Manual, WindowSize->{595, 473}, WindowMargins->{{3, Automatic}, {Automatic, 5}} ] (*********************************************************************** Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. ***********************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{ Cell[1739, 51, 111, 3, 121, "Title"], Cell[1853, 56, 250, 4, 44, "SmallText"], Cell[2106, 62, 328, 9, 52, "Text"], Cell[2437, 73, 303, 5, 71, "Text"], Cell[2743, 80, 118, 3, 30, "Input", InitializationCell->True], Cell[CellGroupData[{ Cell[2886, 87, 44, 0, 53, "Section"], Cell[2933, 89, 104, 3, 33, "Text"], Cell[3040, 94, 302, 16, 299, "Text"], Cell[3345, 112, 189, 5, 33, "Text"], Cell[3537, 119, 134, 2, 50, "Input"], Cell[3674, 123, 165, 2, 50, "Input"], Cell[3842, 127, 298, 4, 90, "Input"], Cell[4143, 133, 65, 0, 33, "Text"], Cell[4211, 135, 98, 2, 30, "Input"], Cell[4312, 139, 260, 5, 71, "Text"], Cell[4575, 146, 65, 0, 33, "Text"], Cell[4643, 148, 117, 3, 33, "Text"], Cell[4763, 153, 83, 1, 30, "Input"], Cell[4849, 156, 71, 1, 30, "Input"], Cell[4923, 159, 138, 3, 33, "Text"], Cell[5064, 164, 70, 1, 30, "Input"], Cell[5137, 167, 125, 3, 33, "Text"], Cell[5265, 172, 65, 1, 30, "Input"], Cell[5333, 175, 133, 3, 33, "Text"], Cell[5469, 180, 60, 1, 30, "Input"], Cell[5532, 183, 104, 3, 33, "Text"], Cell[5639, 188, 54, 0, 33, "Text"], Cell[5696, 190, 528, 11, 190, "Input"], Cell[6227, 203, 74, 0, 33, "Text"], Cell[6304, 205, 88, 1, 30, "Input"], Cell[6395, 208, 34, 0, 33, "Text"], Cell[6432, 210, 136, 2, 70, "Input"], Cell[6571, 214, 173, 3, 52, "Text"], Cell[6747, 219, 72, 1, 44, "Input"], Cell[6822, 222, 64, 1, 30, "Input"], Cell[6889, 225, 95, 2, 33, "Text"], Cell[6987, 229, 248, 8, 33, "Text"], Cell[7238, 239, 77, 1, 31, "Input"], Cell[7318, 242, 133, 3, 33, "Text"], Cell[7454, 247, 122, 3, 33, "Text"], Cell[7579, 252, 50, 1, 30, "Input"], Cell[7632, 255, 470, 8, 90, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[8139, 268, 39, 0, 33, "Section"], Cell[CellGroupData[{ Cell[8203, 272, 42, 0, 47, "Subsection"], Cell[8248, 274, 217, 5, 52, "Text"], Cell[8468, 281, 540, 9, 110, "Input"], Cell[9011, 292, 127, 5, 33, "Text"], Cell[9141, 299, 171, 3, 50, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[9349, 307, 61, 0, 31, "Subsection"], Cell[9413, 309, 52, 0, 33, "Text"], Cell[9468, 311, 163, 3, 50, "Input"], Cell[9634, 316, 34, 0, 33, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[9705, 321, 51, 0, 31, "Subsection"], Cell[9759, 323, 166, 3, 52, "Text"], Cell[9928, 328, 681, 25, 41, "Text", Evaluatable->False], Cell[10612, 355, 1384, 50, 95, "Text"], Cell[11999, 407, 126, 2, 50, "Input"], Cell[12128, 411, 109, 2, 42, "Input"], Cell[12240, 415, 153, 3, 86, "Input"], Cell[12396, 420, 552, 21, 41, "Text"], Cell[12951, 443, 223, 5, 70, "Input"], Cell[13177, 450, 98, 2, 33, "Text"], Cell[13278, 454, 240, 5, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[13555, 464, 65, 0, 31, "Subsection"], Cell[13623, 466, 585, 21, 60, "Text"], Cell[14211, 489, 461, 8, 170, "Input"], Cell[14675, 499, 48, 0, 33, "Text"], Cell[14726, 501, 401, 14, 41, "Text", Evaluatable->False], Cell[15130, 517, 227, 4, 52, "Text"], Cell[15360, 523, 192, 4, 63, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[15601, 533, 35, 0, 33, "Section"], Cell[CellGroupData[{ Cell[15661, 537, 42, 0, 46, "Subsection"], Cell[15706, 539, 234, 5, 46, "Text"], Cell[15943, 546, 443, 7, 75, "Input"], Cell[16389, 555, 127, 5, 32, "Text"], Cell[16519, 562, 173, 3, 59, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[16729, 570, 61, 0, 30, "Subsection"], Cell[16793, 572, 109, 3, 30, "Text"], Cell[16905, 577, 189, 4, 43, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[17131, 586, 52, 0, 30, "Subsection"], Cell[17186, 588, 158, 3, 52, "Text"], Cell[17347, 593, 485, 17, 41, "Text", Evaluatable->False], Cell[17835, 612, 1167, 38, 95, "Text"], Cell[19005, 652, 132, 2, 50, "Input"], Cell[19140, 656, 169, 4, 44, "Input"], Cell[19312, 662, 108, 2, 30, "Input"], Cell[19423, 666, 429, 15, 41, "Text"], Cell[19855, 683, 197, 4, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[20089, 692, 65, 0, 30, "Subsection"], Cell[20157, 694, 121, 4, 33, "Text"], Cell[20281, 700, 72, 1, 30, "Input"], Cell[20356, 703, 367, 14, 41, "Text"], Cell[20726, 719, 474, 9, 190, "Input"], Cell[21203, 730, 111, 3, 33, "Text"], Cell[21317, 735, 64, 2, 50, "Input"], Cell[21384, 739, 168, 3, 52, "Text"], Cell[21555, 744, 505, 13, 190, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[22097, 762, 43, 0, 30, "Subsection"], Cell[22143, 764, 122, 3, 33, "Text"], Cell[22268, 769, 865, 32, 42, "Text", Evaluatable->False], Cell[23136, 803, 699, 22, 90, "Text"], Cell[CellGroupData[{ Cell[23860, 829, 301, 7, 70, "Input"], Cell[24164, 838, 107, 5, 33, "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[24320, 849, 54, 0, 30, "Subsection"], Cell[24377, 851, 230, 11, 32, "Text"], Cell[24610, 864, 157, 4, 47, "Input"], Cell[24770, 870, 44, 0, 30, "Text"], Cell[24817, 872, 178, 3, 59, "Input"], Cell[24998, 877, 64, 0, 30, "Text"], Cell[25065, 879, 109, 2, 43, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[25211, 886, 40, 0, 30, "Subsection"], Cell[25254, 888, 471, 8, 78, "Text"] }, Closed]] }, Closed]] }, Open ]] } ] *) (*********************************************************************** End of Mathematica Notebook file. ***********************************************************************)