(************** Content-type: application/mathematica **************

                    Mathematica-Compatible Notebook

This notebook can be used with any Mathematica-compatible
application, such as Mathematica, MathReader or Publicon. 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[     10783,        253]*)
(*NotebookOutlinePosition[     11681,        283]*)
(*  CellTagsIndexPosition[     11637,        279]*)
(*WindowFrame->Normal*)



Notebook[{

Cell[CellGroupData[{
Cell[TextData["Leslie Matrices"], "Title",
  Evaluatable->False,
  CellHorizontalScrolling->False,
  TextAlignment->Center],

Cell[CellGroupData[{

Cell["Analyzing the Growth Rate of the Population", "Section"],

Cell["\<\
The following matrix describes the pattern of growth of a particular species \
of weasels. The first row represents the birthrate for each particular \
category and the other rows describe the survival rate of each age category \
in moving to the next age category after the passage of some  period of time. \
All weasels in the last age category die off.\
\>", "Text"],

Cell[BoxData[{
    \(Clear[freq, eig, scmatr, m]\), "\n", 
    \(Print["\<m = \>", 
      MatrixForm[
        m = {{0, 0, 1/2, 4/5, 3/10, 0}, {4/5, 0, 0, 0, 0, 
              0}, \[IndentingNewLine]{0, 9/10, 0, 0, 0, 0}, {0, 0, 9/10, 0, 
              0, 0}, \[IndentingNewLine]{0, 0, 0, 8/10, 0, 0}, {0, 0, 0, 0, 
              3/10, 0}}]]\)}], "Input"],

Cell[TextData[{
  "Suppose that you started with 50 newborns, 40 in the next age category, 30 \
in the next, 20 in the next, and 10 in the next and 5 in the last. We will \
call that age[1]. Then we will define the number of weasels in each category \
\"n\" periods down the road as the matrix above to the ",
  Cell[BoxData[
      \(TraditionalForm\`n\^th\)]],
  " power times the initial state age[1]. We can check this out to see what \
is happening for the first few periods."
}], "Text"],

Cell[BoxData[{
    \(Clear[age, total, col]\), "\[IndentingNewLine]", 
    \(\(age[1] = {50. , 40. , 30. , 20. , 10. , 
          5. };\)\), "\[IndentingNewLine]", 
    \(age[n_] := MatrixPower[m, n - 1] . age[1]\), "\[IndentingNewLine]", 
    \(Table[age[i], {i, 1, 51, 10}] // MatrixForm\)}], "Input"],

Cell["\<\
It looks as though the population is growing steadily. Let's write a function \
that will tell us the total number of weasels in any one period (sum of all \
age groups in that period).\
\>", "Text"],

Cell[BoxData[{
    \(total[
        n_] := \[Sum]\+\(i = 1\)\%5\( age[n]\)\[LeftDoubleBracket]
          i\[RightDoubleBracket]\), "\[IndentingNewLine]", 
    \(Table[total[i], {i, 1, 51, 5}] // TableForm\)}], "Input"],

Cell["\<\
It looks as though we are in trouble, unless you like having a lot of \
weasels! 
Before we tackle the job of weasel control, we are going to look at some \
different perspectives on the percentages of weasels in each category. \
\>", "Text"],

Cell[BoxData[
    \(TableForm[
      percentages = Table[age[i]/total[i], {i, 1, 51, 5}]]\)], "Input"],

Cell[TextData[{
  "It looks as though the percentages are leveling out. I wonder if this has \
anything to do with the initial state of if it is associated only with the \
matrix. ",
  StyleBox["Go back and change the age[1] and see if it makes any difference \
in these percentages.",
    FontColor->RGBColor[1, 0, 0]]
}], "Text"],

Cell["\<\
Now, we will examine the matrix in more depth. First we will look at the \
pattern of the columns of the matrix. It is hard to do that based on the \
numbers appearing, so we will take each column (k) and divide it by the sum \
of the entries in that column (k). We then recreate the matrix only now the \
entries are scaled as percentages of their column totals.\
\>", "Text"],

Cell[BoxData[{
    \(Clear[col]\), "\[IndentingNewLine]", 
    \(\(wp51 = MatrixPower[m, 51];\)\), "\n", 
    \(col[k_] := 
      Table[wp51\[LeftDoubleBracket]j, k\[RightDoubleBracket]\/\(\[Sum]\+\(i \
= 1\)\%6 wp51\[LeftDoubleBracket]i, k\[RightDoubleBracket]\), {j, 1, 
          6}]\), "\n", 
    \(TableForm[scmatr = Transpose[Table[col[k], {k, 1, 6}]]] // 
      N\)}], "Input"],

Cell[TextData[{
  StyleBox["Do these rows remind you of the percentages above?\n",
    FontColor->RGBColor[1, 0, 0]],
  "\nNext we will explore the eigenvalues and corresponding eigenvectors for \
the transition matrix. I have pulled out the eigenvector corresponding to the \
largest eigenvalue and scaled it so that the sum of the components is one.\n\
",
  StyleBox["Does this last result look familiar?",
    FontColor->RGBColor[1, 0, 0]]
}], "Text"],

Cell[BoxData[{
    \(TableForm[eig = Eigensystem[m] // N]\), "\n", 
    \(eig[\([2, 2]\)]/Sum[eig[\([2, 2, i]\)], {i, 1, 6}]\)}], "Input",
  PageWidth->Infinity],

Cell[TextData[StyleBox["Why is there so much similarity in these three \
results - the percentages in each group, the columns of the matrix after it \
is raised to a power, and the eigenvector associated with the largest \
eigenvalue? Make the connections!",
  FontSize->16,
  FontColor->RGBColor[1, 0, 0]]], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Your Job - Controlling the Population", "Section"],

Cell[TextData[{
  "Now that you have considered how the population is growing and you have \
explored the relationships between the growth rate and the eigenvalues and \
eigenvectors of the population, you are ready to tackle the problem of \
controlling the weasel overpopulation problem. You have been put in charge of \
harvesting them. Let's assume that harvesting means removing them from this \
setting. However, to preserve the biodiversity of the environment, you do not \
want to kill them all off. You don't mind if the population size stays at the \
150 that you started with. Your job is to come up with a matrix which you \
will subtract from the original matrix \"m\" so that the result will be to \
prevent overpopulation but preservation of the number you started with.\n\n\
One way you could accomplish this would be to eliminate the same percentages, \
say, \"c\", from each age category. That is described below. \n",
  StyleBox["You need to play around with the value for c until you land on \
one that keeps you with the same population size. \nWhen you find one, I want \
you to analyze the corresponding real eigenvalues and see what is different \
compared to the largest eigenvalue of m. \nIn fact, in the case below, where \
we are cutting too many, what do you notice about the value of the largest \
real eigenvalue? \nDraw some general conclucions about the real eigenvalues \
of the transition matrix as they pertain to the stability of the size of the \
population in the long term.",
    FontColor->RGBColor[1, 0, 0]]
}], "Text"],

Cell[BoxData[{\(Clear[age, new, total]\), "\[IndentingNewLine]", 
    RowBox[{
      RowBox[{"c", "=", 
        StyleBox[".2",
          FontColor->RGBColor[1, 0, 0]]}], 
      ";"}], "\[IndentingNewLine]", \(h = {{c, 0, 0, 0, 0, 0}, {0, c, 0, 0, 
            0, 0}, {0, 0, c, 0, 0, 0}, {0, 0, 0, c, 0, 0}, {0, 0, 0, 0, c, 
            0}, {0, 0, 0, 0, 0, c}};\), "\[IndentingNewLine]", \(new = 
      m - h\), "\[IndentingNewLine]", \(Print["\<The eigenvalues of the new \
matrix are \>", 
      Eigenvalues[
        new]]\), "\[IndentingNewLine]", \(age[1] = {50, 40, 30, 20, 10, 
          5};\), "\[IndentingNewLine]", \(age[n_] := 
      MatrixPower[new, n - 1] . age[1]\), "\[IndentingNewLine]", \(total[
        n_] := \[Sum]\+\(i = 1\)\%5\( age[n]\)\[LeftDoubleBracket]
          i\[RightDoubleBracket]\), "\[IndentingNewLine]", \(Print["\<The \
number in each age group after 10 periods is \>", 
      age[10]]\), "\[IndentingNewLine]", \(Print["\<The total number of \
weasels after 10 periods is \>", total[10]]\)}], "Input"],

Cell[TextData[StyleBox["What if you approached the problem by trying to \
decrease the fertility rate and did not make any attempt to remove any of the \
weasels. In that case, your matrix to subtract from \"m\" would be one in \
which every entry was zero except for the last three entries in the first \
row. Could you control the mouse population that way? Find a value of d that \
works.",
  FontColor->RGBColor[1, 0, 0]]], "Text"],

Cell[BoxData[{\(Clear[age, new, total]\), "\[IndentingNewLine]", 
    RowBox[{
      RowBox[{"d", "=", 
        StyleBox[".1",
          FontColor->RGBColor[1, 0, 0]]}], 
      ";"}], "\[IndentingNewLine]", \(h = {{0, 0, d, d, d, 0}, {0, 0, 0, 0, 
            0, 0}, {0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 
            0}, {0, 0, 0, 0, 0, 0}};\), "\[IndentingNewLine]", \(new = 
      m - h\), "\[IndentingNewLine]", \(Print["\<The eigenvalues of the new \
matrix are \>", 
      Eigenvalues[
        new]]\), "\[IndentingNewLine]", \(age[1] = {50, 40, 30, 20, 10, 
          5};\), "\[IndentingNewLine]", \(age[n_] := 
      MatrixPower[new, n - 1] . age[1]\), "\[IndentingNewLine]", \(total[
        n_] := \[Sum]\+\(i = 1\)\%5\( age[n]\)\[LeftDoubleBracket]
          i\[RightDoubleBracket]\), "\[IndentingNewLine]", \(Print["\<The \
number in each age group after 10 periods is \>", 
      age[10]]\), "\[IndentingNewLine]", \(Print["\<The total number of \
weasels after 10 periods is \>", total[10]]\)}], "Input"],

Cell[TextData[StyleBox["Finally, look at a combination of the two methods \
above and make a recommendation to your supervisor.\nRelate this to what \
might be applied to control the bison herd in Yellowstone Park.",
  FontColor->RGBColor[1, 0, 0]]], "Text"]
}, Closed]]
}, Open  ]]
},
FrontEndVersion->"4.1 for Microsoft Windows",
ScreenRectangle->{{0, 1024}, {0, 695}},
WindowToolbars->{},
WindowSize->{581, 556},
WindowMargins->{{10, Automatic}, {Automatic, 15}},
PrintingCopies->1,
PrintingPageRange->{Automatic, Automatic},
PrivateNotebookOptions->{"ColorPalette"->{RGBColor, -1}},
ShowCellLabel->True,
ShowCellTags->False,
RenderingOptions->{"ObjectDithering"->True,
"RasterDithering"->False}
]

(*******************************************************************
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[1727, 52, 123, 3, 115, "Title",
  Evaluatable->False],

Cell[CellGroupData[{
Cell[1875, 59, 62, 0, 59, "Section"],
Cell[1940, 61, 379, 6, 90, "Text"],
Cell[2322, 69, 354, 7, 130, "Input"],
Cell[2679, 78, 492, 9, 90, "Text"],
Cell[3174, 89, 303, 5, 90, "Input"],
Cell[3480, 96, 209, 4, 52, "Text"],
Cell[3692, 102, 218, 4, 73, "Input"],
Cell[3913, 108, 252, 5, 71, "Text"],
Cell[4168, 115, 102, 2, 30, "Input"],
Cell[4273, 119, 331, 7, 71, "Text"],
Cell[4607, 128, 387, 6, 90, "Text"],
Cell[4997, 136, 384, 8, 108, "Input"],
Cell[5384, 146, 454, 9, 128, "Text"],
Cell[5841, 157, 161, 3, 50, "Input"],
Cell[6005, 162, 316, 5, 83, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[6358, 172, 56, 0, 39, "Section"],
Cell[6417, 174, 1561, 22, 375, "Text"],
Cell[7981, 198, 1036, 18, 275, "Input"],
Cell[9020, 218, 435, 6, 90, "Text"],
Cell[9458, 226, 1036, 18, 275, "Input"],
Cell[10497, 246, 258, 3, 52, "Text"]
}, Closed]]
}, Open  ]]
}
]
*)



(*******************************************************************
End of Mathematica Notebook file.
*******************************************************************)