(***********************************************************************
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[ 32955, 1256]*)
(*NotebookOutlinePosition[ 33907, 1288]*)
(* CellTagsIndexPosition[ 33863, 1284]*)
(*WindowFrame->Normal*)
Notebook[{
Cell["Population Dynamics", "Title",
Evaluatable->False,
TextAlignment->Left,
TextJustification->0,
AspectRatioFixed->True],
Cell["Mathematical Modeling", "Subtitle",
Evaluatable->False,
TextAlignment->Left,
TextJustification->0,
AspectRatioFixed->True],
Cell["\<\
Richard Hitt
Department of Mathematics and Statistics
University of South Alabama
Mobile, AL 36688\
\>", "Subsubtitle",
Evaluatable->False,
TextAlignment->Left,
TextJustification->0,
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["Fibonacci Growth", "Section",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Perhaps one of the first mathematical models of a population growth \
was due to Leonardo Pisano (Fibonacci) in 1202. In this setting, we assume \
we have a newborn pair of rabbits who will eventually mate. We assume that \
rabbits are born in oppositely sexed pairs which become sexually mature at \
age 1 month and that the gestational term is 1 month.
Let F[n] denote the number of pairs of rabbits at the end of each month. \
Lets look at different ways we can compute the number of rabbits at the end \
of the nth month.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["\<\
Simple but Inneficient Mathematica Code for the Fibonacci \
Recurrence\
\>", "Subsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The most natural was to describe the Fibonacci relation to \
Mathematica is as follows.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
F[1] = F[2] = 1;
F[n_] := F[n-1] + F[n-2]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
Note that if we want to make a table of Fibonacci numbers, this \
formula for F[n] is horribly inefficient. Explain why. You can use the \
Timing function in Mathematica to measure how long a calculation takes (in \
CPU seconds, not wall clock time). Of course, the value of the Timing output \
will vary from machine to machine.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["Timing[Table[F[n],{n,1,15}]]", "Input",
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Improved Code", "Subsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Mathematica can be convinced to cache its previously computed \
information about a sequence as follows.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Clear[F2];
F2[1] = F2[2] = 1;
F2[n_] := F2[n] = F2[n-1] + F2[n-2]
Timing[Table[F2[n], {n,1,100}]]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
This approach is great if n is not too large. However, it is easy \
to exceed Mathematica's recursion depth if n is large. You can experiment \
with this approach, but you should clear Mathematica's memory of the cached \
F2 values if you run Timing tests so you are not using previously stored \
information.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell[BoxData[
\(Timing[Table[F2[500]]]\)], "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell["Another Approach", "Subsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The disadvantage in the above improvement is that in order to \
compute a Fibonacci number, all the intermediate numbers are stored as rules. \
This will eventually require a large amount of storage for a term in the \
sequence if the index n is very large. In fact, for sufficiently large n, \
the process will fail due to exceeded capacity. Also, the lookup procedure \
for rules is slow. These problems can be overcome with an iterative \
procedure.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
F3[n_] :=
Block[{f = 1, f1 = 0},
Do[ {f, f1} = {f + f1, f}, {n - 1} ];
f
]\
\>", "Input",
AspectRatioFixed->True],
Cell["Timing[Table[F3[n],{n,1,100}]][[1]]", "Input",
AspectRatioFixed->True],
Cell["Timing[F3[1000]]", "Input",
AspectRatioFixed->True],
Cell["\<\
This procedure really flies. It does not have the recursion depth \
restriction of the previous procedure.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Graphs", "Subsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
To determine the growth rate of the Fibonacci sequence, we can plot \
the points.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["ListPlot[Table[F3[n],{n,1,10}],AxesOrigin->{0,0}]", "Input",
AspectRatioFixed->True],
Cell["\<\
Is this exponential? To see, we can plot the log of the data. In \
fact, we can let the data go further out.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["ListPlot[Log[Table[F3[n],{n,1,100}]]]", "Input",
AspectRatioFixed->True],
Cell["\<\
Since the log plot looks linear, the data are probably exponential \
in growth, at least over the range we are examining. This observation is \
made more precise in the next subsection.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["A Closed Form Method", "Subsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
In this subsection, we will derive the standard closed form formula \
for the Fibonacci sequence to show that the terms grow exponentially.\
\>", \
"Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The method used to compute F3 can be rewritten in matirx \
form.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["A = {{1,1},{1,0}};", "Input",
AspectRatioFixed->True],
Cell["\<\
Now the Fibonacci sequence can be described by a matrix equation \
with appropriate initial conditions.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["X[n_] := A . X[n-1]; X[1] = {{1},{0}};", "Input",
AspectRatioFixed->True],
Cell["\<\
Since the eigenvectors of the matrix A are distinct, the basis can \
be changed to an eigenbasis (a basis consisting of distinct eigenvectors) in \
order to solve the system.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["T = Transpose[Eigenvectors[A]];", "Input",
AspectRatioFixed->True],
Cell["\<\
Under this new basis, the coupled recurrence equations become \
uncoupled since the coefficient matrix A is transformed into a disgonal \
matrix of eigenvalues.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["MatrixForm[Simplify[Inverse[T] . A . T]]", "Input",
AspectRatioFixed->True],
Cell["\<\
This shows that the formula, X[n], for the nth term of the \
Fibonacci sequence is a linear combination of powers, say nth, of the two \
eigenvalues. A formula for X[n] can now be determined as follows.\
\>", \
"Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Clear[c1, c2, e1, e2];
{e1,e2} = Eigenvalues[A];
sol=
Solve[
{c1 + c2 == 0, c1 e1 + c2 e2 == 1},
{c1, c2}
]\
\>", "Input",
AspectRatioFixed->True],
Cell["{c1, c2} = {c1, c2} /. sol[[1]]", "Input",
AspectRatioFixed->True],
Cell["\<\
This shows that a closed form formula for the nth term of the \
Fibonacci sequence is given by\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["OutputForm[c1 e1^n + c2 e2^n]", "Input",
AspectRatioFixed->True],
Cell["\<\
Since e1 is less than one in absolute value, the first term will go \
to zero as n gets large. Thus for large n, the Fibonacci sequence is \
approximately c2*e2^n -- exponential!\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
To implement this closed form description as a Mathematica \
definition is easy.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["F4[n_] := Expand[c1 e1^n + c2 e2^n]", "Input",
AspectRatioFixed->True],
Cell[BoxData[
\(Timing[F4[100]]\)], "Input"],
Cell[BoxData[
\(Timing[F4[1000]]\)], "Input"],
Cell["\<\
Notice that there is a considerable amount of algebra being done by \
Mathematica when using this formula to compute large terms in the sequence.\
\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell["Malthusian Growth", "Section",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Thomas Malthus (1766-1834) is generally credited with the idea that \
populations tend to grow exponentially. Exponential growth (or decay) occurs \
whenever the rate of change over time of a variable is directly proportional \
to the value of the variable. To see this in Mathematica, we use will K as \
the constant of proportionality.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
solution1=
DSolve[{P'[t] == K P[t], P[0] == a}, P[t], t]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
We can plot several solution curves at once to see the behaviour of \
the solutions.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
K = 1;
Plot[
Evaluate[
Table[
P[t] /. solution1,
{a,.4,4,.2}
]
],
{t,0,4},
PlotRange -> {0,20}
]
\
\>", "Input",
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Logistic Growth", "Section",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
According to Malthus, although populations tend to increase \
exponentially, resources which support populations (e.g. food) tend to grow \
only linearly. As the exponential growth of the population outstrips the \
linear growth of the resources, the resulting constraints would damp the \
population growth.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
We can build in this dampening effect of excessive growth into the \
differential equation of the previous section. Instead of P' being linear in \
P, we will make it quadratic in P. This approach is called the logistic \
equation. It was introduced by the Belgian statistician Pierre-Francois \
Verhulst (1804-1849).\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["P'[t_] = (1 - P[t]/K)*P[t]", "Text",
Evaluatable->False,
TextAlignment->Center,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["\<\
With this model, the rate of change of P will be 0 when P=0 and \
when P=K. Before we actually solve this DE, we will analyze it graphically \
using vector fields.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["<True],
Cell["\<\
Clear[K,f,P];
K=1;
f[t_,P_] := (1-P/K)*P\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
PlotVectorField[
{1,f[t,P]},
{t,0,4},
{P,0,2},
Axes->True,
AxesLabel->{\"t\",\"P\"}
]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
Note that P' does not depend at all on t. It only depends on P. \
So all the columns of vectors in the above vector field are identical.\
\>", \
"Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Clear[K,a,P]
K=1;\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
solution =
Table[
DSolve[
{ P'[t] == (1 - P[t]/K)*P[t], P[0] == a },
P[t],
t
],
{a,.1,1.7,.2}
]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
We have to get rid of the outer set of braces to provide suitable \
input for the ParametricPlot function. We do this with the Flatten command \
shown below.\
\>", "Text"],
Cell["\<\
Plot[
Evaluate[P[t] /. Flatten[solution,1]],
{t,0,4}
]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
If, instead of having P' quadratic in P, we make P' cubic in P. We \
can build a model which has three stationary points: P = 0, T, K (T0. And for P>K, we want P'<0. A cubic function with \
these properties is easily constructed.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
K=5; T=1;
g[P_] := (P/T - 1)*(1 - P/K)*P
Plot[g[P],{P,0,6},AxesLabel->{\"P\",\"P'\"}]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
We use this cubic function to assign values to P' in a differential \
equation. The we plot solution curves for various values of the intial \
condition.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
solution =
Table[
NDSolve[
{ P'[t] == (P[t]/T - 1)*(1 - P[t]/K)*P[t],
P[0] == a
},
P[t],
{t,0,2}
],
{a,.3,7,.3}
];\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
Plot[
Evaluate[P[t] /. Flatten[solution,1]],
{t,0,2},
PlotRange->{0,7}
]\
\>", "Input",
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Lotka-Volterra Predator-Prey Populations", "Section",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Vito Volterra was an Italian mathematician who lived from \
1860-1940. His son-in-law, Humberto D'Ancona was an Italian biologist who, \
in 1926, completed a statistical study of fish populations in the Adriadic \
Sea. D'Ancona asked Volterra if there was a mathematical model which could \
explain the increase in predator fish (and corresponding decrease in prey \
fish) which he observed during the World War I period. Within a couple of \
months, Volterra produced a series of models for the interaction of two or \
more species. Alfred J. Lotka was an American biologist and actuary who \
independently produced many of the same models.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The simplest of their models can be described by letting
x(t) = predator population at time t;
y(t) = prey population at time t;
a = the natural rate of decay of the predator population if there are \
no prey;
b = the natural rate of growth of the prey population if there are no \
prey;
c = the efficiency with which predators convert prey encounters into \
offspring,
d = the rate of decrease of prey due to encounter with predators.\
\>", \
"Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The simplest Lotka-Volterra system for modeling predator-prey \
interactions is\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
x'[t] = -a x[t] + c x[t] y[t]
y'[t] = b y[t] - d x[t] y[t]\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["For a specific example, we consider the following.", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
eqn={x'[t]== -x[t] + x[t] y[t],
y'[t]== 3y[t] - x[t] y[t],
x[0]==x0,
y[0]==1} ;\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
In order to graph several solution curves, we make a table of \
solutions.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
tbl =
Table[
NDSolve[
eqn,
{x,y},
{t,0,6}
],
{x0,.2,3,.3}
] ;\
\>", "Input",
AspectRatioFixed->True],
Cell["Then we can plot the solutions together.", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
ParametricPlot[
Evaluate[
{ x[t],y[t] } /. Flatten[tbl,1]
],
{t,0,6}
]\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
There are many variations on the Lotka-Volterra equations. Here is \
one example which introduces an additional quadratic term in the rate of \
change of y.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
eqn={x'[t]== -x[t] + x[t] y[t],
y'[t]== 3y[t] - x[t] y[t] - y[t]^2,
x[0]==x0,
y[0]==1} ;\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
tbl =
Table[
NDSolve[
eqn,
{x,y},
{t,-3,3}
],
{x0,.2,1.7,.3}
] ;\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
ParametricPlot[
Evaluate[
{ x[t],y[t] } /. Flatten[tbl,1]
],
{t,-3,3}
]\
\>", "Input",
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Competitive Exclusion", "Section"],
Cell["\<\
Instead of a predator-prey relationship, two species may compete \
with each other for the same niche in an ecosystem. How can this \
relationship be modeled? As you would expect, there are many ways to do \
this. Perhaps the most direct way is to modify the predator-prey system as \
follows:\
\>", "Text"],
Cell["\<\
x'[t] = a x[t] - b x[t] y[t]
y'[t] = c y[t] - d x[t] y[t]\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["\<\
You get an opportunity to explain the differential equations in the \
exercises below!\
\>", "Text"],
Cell["\<\
First, we get a feel for the solutions to the system by plotting \
the vector field.\
\>", "Text"],
Cell[BoxData[
\(<< Graphics`PlotField`\)], "Input"],
Cell[BoxData[
\(PlotVectorField[{0.1\ x - 0.01\ x*y,
0.2\ y - 0.05\ x*y}, \n\ \ \ \ \ \ \ \ \ \ \ \ \ {x, \ 0, \
12}, \ {y, \ 0, \ 15}, \ Frame -> True, \
PlotPoints -> 20]\)], "Input"],
Cell["For a specific example, we consider the following.", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
eqn={x'[t]== 0.1 x[t] - 0.01 x[t] y[t],
y'[t]== 0.2 y[t] - 0.05 x[t] y[t],
x[0]==x0,
y[0]==y0} ;\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
In order to graph several solution curves, we make a table of \
solutions.\
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
tbl =
Table[
NDSolve[
eqn,
{x,y},
{t,0,20}
],
{x0,1,9,1},
{y0,1,19,2}
] ;\
\>", "Input",
AspectRatioFixed->True],
Cell["Then we can plot the solutions together.", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
ParametricPlot[
Evaluate[
{ x[t],y[t] } /. Flatten[tbl,2]
],
{t,0,20},PlotRange->{{0,10},{0,20}}
]\
\>", "Input",
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercises", "ExerciseMain",
Evaluatable->False,
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["Exercise 1", "Exercise",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Discuss the different methods described in this notebook for \
computing the terms of the Fibonacci sequence. Analyze the run times of the \
methods. You can use the Timing function to gather data. You can also count \
the number of operations required for each of the methods.\
\>", \
"ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 2", "Exercise",
Evaluatable->False,
AspectRatioFixed->True],
Cell[TextData[{
"Starting in 1790, the U. S. population has been measured every 10 years. \
The following data have been collected (see ",
ButtonBox["http://www.census.gov/dmd/www/resapport/states/unitedstates.xls",
ButtonData:>{
URL[ "http://www.census.gov/dmd/www/resapport/states/unitedstates.xls"],
None},
ButtonStyle->"Hyperlink"],
")"
}], "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell[BoxData[
StyleBox[GridBox[{
{
StyleBox["Year",
"NumberedTable"],
StyleBox[\(U . S . \ Population\),
"NumberedTable"]},
{
StyleBox["1790",
FontWeight->"Plain"],
StyleBox["3929214",
FontWeight->"Plain"]},
{
StyleBox["1800",
FontWeight->"Plain"],
StyleBox["5308483",
FontWeight->"Plain"]},
{
StyleBox["1810",
FontWeight->"Plain"],
StyleBox["7239881",
FontWeight->"Plain"]},
{
StyleBox["1820",
FontWeight->"Plain"],
StyleBox["9638453",
FontWeight->"Plain"]},
{
StyleBox["1830",
FontWeight->"Plain"],
StyleBox["12860702",
FontWeight->"Plain"]},
{
StyleBox["1840",
FontWeight->"Plain"],
StyleBox["17063353",
FontWeight->"Plain"]},
{
StyleBox["1850",
FontWeight->"Plain"],
StyleBox["23191876",
FontWeight->"Plain"]},
{
StyleBox["1860",
FontWeight->"Plain"],
StyleBox["31443321",
FontWeight->"Plain"]},
{
StyleBox["1870",
FontWeight->"Plain"],
StyleBox["38558371",
FontWeight->"Plain"]},
{
StyleBox["1880",
FontWeight->"Plain"],
StyleBox["50189209",
FontWeight->"Plain"]},
{
StyleBox["1890",
FontWeight->"Plain"],
StyleBox["62979766",
FontWeight->"Plain"]},
{
StyleBox["1900",
FontWeight->"Plain"],
StyleBox["76212168",
FontWeight->"Plain"]},
{
StyleBox["1910",
FontWeight->"Plain"],
StyleBox["92228496",
FontWeight->"Plain"]},
{
StyleBox["1920",
FontWeight->"Plain"],
StyleBox["106021537",
FontWeight->"Plain"]},
{
StyleBox["1930",
FontWeight->"Plain"],
StyleBox["123202624",
FontWeight->"Plain"]},
{
StyleBox["1940",
FontWeight->"Plain"],
StyleBox["132164569",
FontWeight->"Plain"]},
{
StyleBox["1950",
FontWeight->"Plain"],
StyleBox["151325798",
FontWeight->"Plain"]},
{
StyleBox["1960",
FontWeight->"Plain"],
StyleBox["179323175",
FontWeight->"Plain"]},
{
StyleBox["1970",
FontWeight->"Plain"],
StyleBox["203302031",
FontWeight->"Plain"]},
{
StyleBox["1980",
FontWeight->"Plain"],
StyleBox["226542199",
FontWeight->"Plain"]},
{
StyleBox["1990",
FontWeight->"Plain"],
StyleBox["248709873",
FontWeight->"Plain"]},
{
StyleBox["2000",
FontWeight->"Plain"],
StyleBox["281421906",
FontWeight->"Plain"]}
},
GridFrame->True,
RowLines->True,
ColumnLines->True],
FontWeight->"Plain"]], "NumberedTable"],
Cell["\<\
We want to find a model for the U. S. population growth. To begin, \
we can build the data set from the above table and look at a point \
graph.\
\>", "ExerciseText"],
Cell["\<\
years = Table[1790 + 10n, {n,0,21}];
pop = {3.929214,5.308483,7.239881,9.638453,
\t\t\t12.860702,17.063353,23.191876,31.443321,
\t\t\t38.558371,50.189209,62.979766,76.212168,
\t\t\t92.228496,106.021537,123.202624,132.164569,
\t\t\t151.325798,179.323175,203.302031,226.542199,
248.709873,281.421906};
data = Table[{years[[i]], pop[[i]]}, {i,1,22
}];\
\>", "Input",
AspectRatioFixed->True],
Cell["\<\
ListPlot[
data,
AxesOrigin -> {1780,0},
Prolog -> PointSize[.016]
]\
\>", "Input",
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["Part (a)", "Subsection"],
Cell["\<\
Find an exponential model for the above data. First, use only the \
data from the period 1790 through 1860. Once you have this exponential model \
built, examine how well it conforms to the data after 1860. Comment. Graph \
the data points and the exponential curve on the same set of axes for \
comparison.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Next, build an exponential model which gives a best fit for all the \
data. Again, graph the data and the curve on one set of axes for comparison. \
Comment.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
You may find the NonlinearFit function in the package \
Statistics`NonlinearFit` helpful. You will need to consult the Help section \
to get information about using the NonlinearFit function. You should \
carefully read the information about the function to get an understanding \
what it is doing. \
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell[TextData[{
"To get started with this process, you need to know the general form of the \
function you are trying to fit. Although this is easy for the exponential \
case, you can let ",
StyleBox["Mathematica",
FontSlant->"Italic"],
" do if for you anyway. This will be useful in more complicated examples \
(like the logistic fit problem later in this exercise)."
}], "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell[BoxData[
\(DSolve[{\(P'\)[t] \[Equal] r*P[t], P[1790] \[Equal] 3.9}, P[t], t] //
Simplify\)], "Input"],
Cell["\<\
So we have one parameter, r, to vary in order to find the best fit \
to the dataset.\
\>", "Text"],
Cell[BoxData[
\(<< Statistics`NonlinearFit`\)], "Input"],
Cell[BoxData[
\(fitdata1 =
NonlinearFit[data, 3.9*E^\((r*\((t - 1790)\))\), t, {r, 0},
ShowProgress \[Rule] True]\)], "Input"],
Cell["\<\
You can also leave the initial population unspecified and let the \
power of the NonlinearFit function use that extra variability to improve the \
exponential fit to the data.\
\>", "Text"],
Cell[BoxData[
\(DSolve[{\(P'\)[t] \[Equal] r*P[t], P[1790] \[Equal] a}, P[t], t] //
Simplify\)], "Input"],
Cell[BoxData[
\(fitdata1 =
NonlinearFit[data, a*E^\((r*\((t - 1790)\))\), t, {{a, 3}, {r, 0}},
ShowProgress \[Rule] True]\)], "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell["Part (b)", "Subsection"],
Cell["\<\
Using the same population data, build a logistic model, P' = r \
(1-P/K)P. Use the same method as illustrated in Part (a). Graph the \
logistic model together with the data points on one set of axes and discuss \
the suitability of the model. Then extent the time axis forward in time and \
illustrate the carrying capacity (the K parameter in the model) for the \
model. What is the value of K? Can you offer explanations (based, say, in \
historical facts) for any deviations you see between the model and the \
data?\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 3", "Exercise",
Evaluatable->False],
Cell["\<\
Give a thorough explanation of the equations used in the basic \
predator-prey model. You should fully explain the motivation of the terms \
used in the system of differential equations.\
\>", "ExerciseText"]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 4", "Exercise",
Evaluatable->False],
Cell[TextData[{
"In the variation of the predator-prey model discussed in the lab material \
above, discuss the effect of the ",
Cell[BoxData[
\(TraditionalForm\`y\^2\)]],
" term on the prey population. Try to relate your discussion to topics we \
have already discussed. HINT: Try to find a way to use the word ",
StyleBox["logistic",
FontSlant->"Italic"],
"."
}], "ExerciseText"]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 5", "Exercise",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The equation dP/dt = r*P*(1-P/K) - H gives a logistic type model of \
a population with natural rate r, carrying capacity K and constant harvesting \
rate H (r, K, H positive). \
\>", "Text",
Evaluatable->False,
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["Part A", "Subsubsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
The value H = rK/4 is called the critical harvesting rate. Show \
that the population beocomes extinct if H exceeds this critical harvesting \
rate.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Open ]],
Cell[CellGroupData[{
Cell["Part B", "Subsubsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Plot portraits of solution curves in the quadrant P>0, t>0 for \
three cases: no harvesting (H=0); subcritical harvesting (use H=rK/8); and \
supercritical harvesting (use H=rK/2). Let r=.001, K=1000, and choose \
various values for the initial population.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Open ]]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 6", "Exercise",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Chapters 3 and 4 of the Herod, Shonkwiler, Yeargers text deal with \
populations. Look over these chapters. Carefully read section 4.4 on \
predator-prey problems, especially the discussion on stability around \
equilibrium points.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell[CellGroupData[{
Cell["Part A", "Subsubsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["Now consider the differential equations", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
x'[t] == -x[t] + x[t] y[t]
y'[t] == 3y[t] - x[t] y[t] - y[t]^2
x[0] == x0
y[0] == y0\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["\<\
which were discussed briefly in the lab material. How many \
equilibrium points does this system have? Starting at the point (1,2), graph \
the solution curve as t ranges from 0 to 12. Try a few other starting points \
and do the same thing (modify the upper bound on t if needed). What do you \
conclude? Can you think of a real-world situation which would make the y^2 \
term plausible (perhaps not!)? Explain.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]],
Cell[CellGroupData[{
Cell["Part B", "Subsubsection",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
Now consider a system in which the prey species is limited with a \
logistic growth model, say\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True],
Cell["\<\
x'[t] == -x[t] + x[t] y[t]
y'[t] == y[t] (3-y[t]) - x[t] y[t]
x[0] == x0
y[0] == y0\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["\<\
Draw solution curves beginning at several different starting points \
and explain what is going on in the system.\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell["Exercise 7", "Exercise",
Evaluatable->False],
Cell["Consider the pair of differential equations given by", "ExerciseText"],
Cell["\<\
x'[t] = 0.5 (1 - 0.25 x[t]) - 0.025 x[t] y[t]
y'[t] = 0.1 (1 - 0.125 y[t]) - 0.006 x[t] y[t]\
\>", "ExerciseText",
Evaluatable->False,
AspectRatioFixed->True,
FontFamily->"Courier"],
Cell["\<\
If x[t] and y[t] represent populations at time t, what happens to \
the two populations as time goes by? Draw a set of solutions in the \
xy-plane. Try to superimpose the nullclines on the solutions so you can see \
how they relate. Explain why the results are different than in the \
competitive exclusion example given in the section.\
\>", "ExerciseText"]
}, Closed]]
}, Closed]]
},
FrontEndVersion->"4.0 for Microsoft Windows",
ScreenRectangle->{{0, 1119}, {0, 791}},
WindowToolbars->"EditBar",
CellGrouping->Manual,
WindowSize->{500, 698},
WindowMargins->{{Automatic, 41}, {5, Automatic}},
PrivateNotebookOptions->{"ColorPalette"->{RGBColor, 128}},
ShowCellLabel->True,
ShowCellTags->False,
RenderingOptions->{"ObjectDithering"->True,
"RasterDithering"->False},
CharacterEncoding->"XAutomaticEncoding",
StyleDefinitions -> "Classroom.nb"
]
(***********************************************************************
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[1717, 49, 131, 4, 67, "Title",
Evaluatable->False],
Cell[1851, 55, 136, 4, 41, "Subtitle",
Evaluatable->False],
Cell[1990, 61, 224, 9, 112, "Subsubtitle",
Evaluatable->False],
Cell[CellGroupData[{
Cell[2239, 74, 83, 2, 62, "Section",
Evaluatable->False],
Cell[2325, 78, 603, 12, 167, "Text",
Evaluatable->False],
Cell[CellGroupData[{
Cell[2953, 94, 148, 5, 52, "Subsection",
Evaluatable->False],
Cell[3104, 101, 159, 5, 29, "Text",
Evaluatable->False],
Cell[3266, 108, 92, 4, 68, "Input"],
Cell[3361, 114, 404, 8, 86, "Text",
Evaluatable->False],
Cell[3768, 124, 71, 1, 50, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[3876, 130, 83, 2, 52, "Subsection",
Evaluatable->False],
Cell[3962, 134, 176, 5, 48, "Text",
Evaluatable->False],
Cell[4141, 141, 148, 6, 104, "Input"],
Cell[4292, 149, 383, 8, 67, "Text",
Evaluatable->False],
Cell[4678, 159, 55, 1, 50, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[4770, 165, 86, 2, 52, "Subsection",
Evaluatable->False],
Cell[4859, 169, 528, 10, 105, "Text",
Evaluatable->False],
Cell[5390, 181, 161, 7, 122, "Input"],
Cell[5554, 190, 78, 1, 50, "Input"],
Cell[5635, 193, 59, 1, 50, "Input"],
Cell[5697, 196, 179, 5, 29, "Text",
Evaluatable->False]
}, Closed]],
Cell[CellGroupData[{
Cell[5913, 206, 76, 2, 52, "Subsection",
Evaluatable->False],
Cell[5992, 210, 153, 5, 29, "Text",
Evaluatable->False],
Cell[6148, 217, 92, 1, 50, "Input"],
Cell[6243, 220, 182, 5, 29, "Text",
Evaluatable->False],
Cell[6428, 227, 80, 1, 50, "Input"],
Cell[6511, 230, 258, 6, 48, "Text",
Evaluatable->False]
}, Closed]],
Cell[CellGroupData[{
Cell[6806, 241, 90, 2, 52, "Subsection",
Evaluatable->False],
Cell[6899, 245, 213, 6, 48, "Text",
Evaluatable->False],
Cell[7115, 253, 136, 5, 29, "Text",
Evaluatable->False],
Cell[7254, 260, 61, 1, 50, "Input"],
Cell[7318, 263, 175, 5, 29, "Text",
Evaluatable->False],
Cell[7496, 270, 81, 1, 50, "Input"],
Cell[7580, 273, 246, 6, 48, "Text",
Evaluatable->False],
Cell[7829, 281, 74, 1, 50, "Input"],
Cell[7906, 284, 232, 6, 48, "Text",
Evaluatable->False],
Cell[8141, 292, 83, 1, 50, "Input"],
Cell[8227, 295, 277, 7, 48, "Text",
Evaluatable->False],
Cell[8507, 304, 172, 9, 158, "Input"],
Cell[8682, 315, 74, 1, 50, "Input"],
Cell[8759, 318, 166, 5, 29, "Text",
Evaluatable->False],
Cell[8928, 325, 72, 1, 50, "Input"],
Cell[9003, 328, 251, 6, 48, "Text",
Evaluatable->False],
Cell[9257, 336, 152, 5, 29, "Text",
Evaluatable->False],
Cell[9412, 343, 78, 1, 50, "Input"],
Cell[9493, 346, 48, 1, 50, "Input"],
Cell[9544, 349, 49, 1, 50, "Input"],
Cell[9596, 352, 219, 6, 48, "Text",
Evaluatable->False]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[9864, 364, 84, 2, 42, "Section",
Evaluatable->False],
Cell[9951, 368, 411, 8, 67, "Text",
Evaluatable->False],
Cell[10365, 378, 109, 4, 68, "Input"],
Cell[10477, 384, 156, 5, 29, "Text",
Evaluatable->False],
Cell[10636, 391, 180, 14, 248, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[10853, 410, 82, 2, 42, "Section",
Evaluatable->False],
Cell[10938, 414, 381, 8, 67, "Text",
Evaluatable->False],
Cell[11322, 424, 392, 8, 67, "Text",
Evaluatable->False],
Cell[11717, 434, 140, 4, 29, "Text",
Evaluatable->False],
Cell[11860, 440, 236, 6, 48, "Text",
Evaluatable->False],
Cell[12099, 448, 64, 1, 50, "Input"],
Cell[12166, 451, 91, 5, 86, "Input"],
Cell[12260, 458, 146, 9, 158, "Input"],
Cell[12409, 469, 212, 6, 48, "Text",
Evaluatable->False],
Cell[12624, 477, 68, 4, 68, "Input"],
Cell[12695, 483, 182, 11, 194, "Input"],
Cell[12880, 496, 182, 4, 48, "Text"],
Cell[13065, 502, 109, 6, 104, "Input"],
Cell[13177, 510, 490, 9, 86, "Text",
Evaluatable->False],
Cell[13670, 521, 136, 5, 86, "Input"],
Cell[13809, 528, 226, 6, 48, "Text",
Evaluatable->False],
Cell[14038, 536, 217, 13, 230, "Input"],
Cell[14258, 551, 129, 7, 122, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[14424, 563, 107, 2, 42, "Section",
Evaluatable->False],
Cell[14534, 567, 717, 12, 124, "Text",
Evaluatable->False],
Cell[15254, 581, 542, 15, 246, "Text",
Evaluatable->False],
Cell[15799, 598, 151, 5, 29, "Text",
Evaluatable->False],
Cell[15953, 605, 160, 6, 60, "Text",
Evaluatable->False],
Cell[16116, 613, 114, 2, 29, "Text",
Evaluatable->False],
Cell[16233, 617, 145, 6, 104, "Input"],
Cell[16381, 625, 146, 5, 29, "Text",
Evaluatable->False],
Cell[16530, 632, 147, 11, 194, "Input"],
Cell[16680, 645, 104, 2, 29, "Text",
Evaluatable->False],
Cell[16787, 649, 131, 8, 140, "Input"],
Cell[16921, 659, 229, 6, 48, "Text",
Evaluatable->False],
Cell[17153, 667, 154, 6, 104, "Input"],
Cell[17310, 675, 150, 11, 194, "Input"],
Cell[17463, 688, 132, 8, 140, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[17632, 701, 40, 0, 42, "Section"],
Cell[17675, 703, 320, 6, 67, "Text"],
Cell[17998, 711, 160, 6, 60, "Text",
Evaluatable->False],
Cell[18161, 719, 110, 3, 29, "Text"],
Cell[18274, 724, 108, 3, 29, "Text"],
Cell[18385, 729, 55, 1, 50, "Input"],
Cell[18443, 732, 214, 4, 70, "Input"],
Cell[18660, 738, 114, 2, 29, "Text",
Evaluatable->False],
Cell[18777, 742, 162, 6, 104, "Input"],
Cell[18942, 750, 146, 5, 29, "Text",
Evaluatable->False],
Cell[19091, 757, 163, 12, 212, "Input"],
Cell[19257, 771, 104, 2, 29, "Text",
Evaluatable->False],
Cell[19364, 775, 159, 8, 140, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[19560, 788, 81, 2, 44, "ExerciseMain",
Evaluatable->False],
Cell[CellGroupData[{
Cell[19666, 794, 78, 2, 45, "Exercise",
Evaluatable->False],
Cell[19747, 798, 362, 8, 86, "ExerciseText",
Evaluatable->False]
}, Closed]],
Cell[CellGroupData[{
Cell[20146, 811, 78, 2, 31, "Exercise",
Evaluatable->False],
Cell[20227, 815, 441, 12, 67, "ExerciseText",
Evaluatable->False],
Cell[20671, 829, 3586, 121, 428, "NumberedTable"],
Cell[24260, 952, 177, 4, 48, "ExerciseText"],
Cell[24440, 958, 420, 11, 212, "Input"],
Cell[24863, 971, 124, 7, 122, "Input"],
Cell[CellGroupData[{
Cell[25012, 982, 30, 0, 52, "Subsection"],
Cell[25045, 984, 391, 8, 86, "ExerciseText",
Evaluatable->False],
Cell[25439, 994, 239, 6, 48, "ExerciseText",
Evaluatable->False],
Cell[25681, 1002, 382, 8, 86, "ExerciseText",
Evaluatable->False],
Cell[26066, 1012, 448, 10, 86, "ExerciseText",
Evaluatable->False],
Cell[26517, 1024, 118, 2, 70, "Input"],
Cell[26638, 1028, 108, 3, 29, "Text"],
Cell[26749, 1033, 60, 1, 50, "Input"],
Cell[26812, 1036, 146, 3, 70, "Input"],
Cell[26961, 1041, 199, 4, 48, "Text"],
Cell[27163, 1047, 116, 2, 70, "Input"],
Cell[27282, 1051, 154, 3, 70, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[27473, 1059, 30, 0, 36, "Subsection"],
Cell[27506, 1061, 605, 11, 143, "ExerciseText",
Evaluatable->False]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[28160, 1078, 52, 1, 31, "Exercise",
Evaluatable->False],
Cell[28215, 1081, 219, 4, 67, "ExerciseText"]
}, Closed]],
Cell[CellGroupData[{
Cell[28471, 1090, 52, 1, 31, "Exercise",
Evaluatable->False],
Cell[28526, 1093, 404, 10, 86, "ExerciseText"]
}, Closed]],
Cell[CellGroupData[{
Cell[28967, 1108, 78, 2, 31, "Exercise",
Evaluatable->False],
Cell[29048, 1112, 249, 6, 48, "Text",
Evaluatable->False],
Cell[CellGroupData[{
Cell[29322, 1122, 79, 2, 45, "Subsubsection",
Evaluatable->False],
Cell[29404, 1126, 229, 6, 48, "ExerciseText",
Evaluatable->False]
}, Open ]],
Cell[CellGroupData[{
Cell[29670, 1137, 79, 2, 45, "Subsubsection",
Evaluatable->False],
Cell[29752, 1141, 337, 7, 86, "ExerciseText",
Evaluatable->False]
}, Open ]]
}, Closed]],
Cell[CellGroupData[{
Cell[30138, 1154, 78, 2, 31, "Exercise",
Evaluatable->False],
Cell[30219, 1158, 313, 7, 67, "ExerciseText",
Evaluatable->False],
Cell[CellGroupData[{
Cell[30557, 1169, 79, 2, 45, "Subsubsection",
Evaluatable->False],
Cell[30639, 1173, 111, 2, 29, "ExerciseText",
Evaluatable->False],
Cell[30753, 1177, 211, 8, 110, "ExerciseText",
Evaluatable->False],
Cell[30967, 1187, 498, 9, 124, "ExerciseText",
Evaluatable->False]
}, Closed]],
Cell[CellGroupData[{
Cell[31502, 1201, 79, 2, 37, "Subsubsection",
Evaluatable->False],
Cell[31584, 1205, 174, 5, 48, "ExerciseText",
Evaluatable->False],
Cell[31761, 1212, 210, 8, 110, "ExerciseText",
Evaluatable->False],
Cell[31974, 1222, 193, 5, 48, "ExerciseText",
Evaluatable->False]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[32216, 1233, 52, 1, 31, "Exercise",
Evaluatable->False],
Cell[32271, 1236, 76, 0, 29, "ExerciseText"],
Cell[32350, 1238, 203, 6, 56, "ExerciseText",
Evaluatable->False],
Cell[32556, 1246, 371, 6, 105, "ExerciseText"]
}, Closed]]
}, Closed]]
}
]
*)
(***********************************************************************
End of Mathematica Notebook file.
***********************************************************************)