(*********************************************************************** Mathematica-Compatible Notebook This notebook can be used on any computer system with Mathematica 3.0, MathReader 3.0, or any compatible application. The data for the notebook starts with the line of 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[ 15049, 457]*) (*NotebookOutlinePosition[ 16104, 493]*) (* CellTagsIndexPosition[ 16060, 489]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{Cell[TextData["CHAPTER 10"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["1"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "Define the transition matrix, find its dominant eigenvalue, and plot it."], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["matrix[r_,s_]:={{(1-s)/(2(1-r)),1/2},{s/(2r),1/2}}"], "Input", AspectRatioFixed->True], Cell[TextData["eigen[r_,s_]:=Eigenvalues[matrix[r,s]]"], "Input", AspectRatioFixed->True], Cell[TextData["lambda[r_,s_]:=Max[eigen[r,s]]\n"], "Input", AspectRatioFixed->True], Cell[TextData["Do[Plot[lambda[r,s],{s,0,1}],{r,0.4,0.6,0.1}]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["2"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["2a"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[{ StyleBox[ "Simplify the first order Taylor series expansion for the eigenvalues. \ [Notes: 1. ", Evaluatable->False, AspectRatioFixed->True], StyleBox["Mathematica", Evaluatable->False, AspectRatioFixed->True, FontSlant->"Italic"], StyleBox[ " will only do the algebraic simplification if the transition matrix has \ been set up with exact rather than numerical expressions. 2. See the caution \ about the use of ", Evaluatable->False, AspectRatioFixed->True], StyleBox["PowerExpand", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox[" in the ", Evaluatable->False, AspectRatioFixed->True], StyleBox["Mathematica", Evaluatable->False, AspectRatioFixed->True, FontSlant->"Italic"], StyleBox[" book; in the present case it reverses the two eigenvalues.]", Evaluatable->False, AspectRatioFixed->True] }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Series[eigen[r,s],{s,r,1}]"], "Input", AspectRatioFixed->True], Cell[TextData["Simplify[%]"], "Input", AspectRatioFixed->True], Cell[TextData["PowerExpand[%]"], "Input", AspectRatioFixed->True], Cell[TextData["Simplify[%]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["2b"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["y=D[Det[matrix[r,s]-IdentityMatrix[2]],s]"], "Input", AspectRatioFixed->True], Cell[TextData["Solve[y==0,r]"], "Input", AspectRatioFixed->True]}, Open]]}, Open]], Cell[CellGroupData[{Cell[TextData["3"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "Define the inclusive fitness and use it to find the optimal sex ratio and to \ check the criteria for stability. (Compare Exercise 8.11.)"], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Clear[r,s]\nw=(r+(1-2r)s)/(2r(1-r));"], "Input", AspectRatioFixed->True], Cell[TextData["Solve[(D[w,s]/.s->r)==0]"], "Input", AspectRatioFixed->True], Cell[TextData["D[w,{s,2}]/.{s->1/2,r->1/2}"], "Input", AspectRatioFixed->True], Cell[TextData["D[w,{s,2}]+D[w,s,r]/.{s->1/2,r->1/2}"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["4"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[{ StyleBox["Redefine ", Evaluatable->False, AspectRatioFixed->True], StyleBox["matrix", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox[ " and then repeat the calculations in the solutions to Exercises 1 and 2.", Evaluatable->False, AspectRatioFixed->True] }], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["5"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "Female genotypes aa, Aa, AA are numbered 1, 2, 3; male genotypes a, A are 4 \ and 5. The six mating types {1x1, 2x1, 3x1, 1x2, 2x2, 3x2} are numbered 1 \ through 6. I first generate a 6x5 matrix m giving the frequencies of \ offspring from the different matingtypes, with sex ratios produced by aa, Aa \ and AA females being r, s and t respectively:"], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "m[r_,s_,t_] = {{1-r,0.,0.,r,0.},{.5(1-s),.5(1-s),0.,.5s,.5s},\n \ {0.,1-t,0.,0.,t},{0.,1-r,0.,r,0.},\n \ {0.,.5(1-s),.5(1-s),.5s,.5s},{0.,0.,1-t,0.,t}};"], "Input", AspectRatioFixed->True], Cell[TextData[ "I next generate the frequencies of the six mating types, mat, in generation \ t given the genotype frequencies p1 through p5, with p1+p2+p3=1 and p4+p5=1 \ and then the standardized genotype frequencies in the next generation:"], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "mat[p_]:=Flatten[Table[p[[i]]*p[[j+3]],{j,2},{i,3}]];\n\ pnext[p_]:=(a=mat[p].m[r,s,t];\n\t\ta1=Sum[a[[i]],{i,3}];\n\t\t\ a2=Sum[a[[i]],{i,4,5}];\n\t\tDo[a[[i]]/=If[i<=3,a1,a2],{i,5}];\n\t\ta)"], "Input", AspectRatioFixed->True], Cell[TextData[ "Simulations can be done by using NestList on the function pnext.\n"], "Text",\ Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["6, 7"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Use pencil and paper."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["8"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["8a"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Use pencil and paper."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["8b"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["See the solution to Exercise 3."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]]}, Open]], Cell[CellGroupData[{Cell[TextData["9"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["9a"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Use pencil and paper."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["9b"], "Subsubsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[{ StyleBox[ "I reproduce the argument of Taylor and Bulmer (1980) for obtaining the \ predicted sex ratio under local mate competition in haplodiploids. Postulate \ a rare allele A and a wild type allele a acting in females. Because the \ population structure leads to inbreeding we have to consider AA as well as Aa \ females, and we suppose that A is dominant to a so that both these types of \ female have sex ratio s, while aa females have sex ratio r. (The argument can \ be repeated with different genetic assumptions and leads to the same result.) \ There are six types of mated female, {0,0}, {0,1}, {1,0}, {1,1}, {2,0} and \ {2,1}, where {i,j} denotes i A genes in the female and j A genes in the sperm \ in her spermatheca derived from her mate. (I assume single mating.) Denote \ these types of mated female 0 through 5; type 0 is common and types 1 through \ 5 are rare. We therefore need to consider six types of patch, types 1 through \ 5 with 1 mated female of type k (k going from 1 through 5) and n-1 females of \ type 0 and patch type 0 with n mated females of type 0. Write p", Evaluatable->False, AspectRatioFixed->True], StyleBox["k", Evaluatable->False, AspectRatioFixed->True, FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[ "(t) for the frequency of patch type k in generation t, assumed small for k \ = 1 through 5. We must now find the linearized recurrence relationship for \ these five frequencies. \n\t\t\t\t\t\t\t\t\t\tThe function ", Evaluatable->False, AspectRatioFixed->True], StyleBox["output[k] ", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox[ "takes a patch of type k and calculates the frequencies of the different \ types of mutant mated females produced by this patch as follows. i and j are \ the numbers of A genes in the mutant foundress and her sperm respectively, \ and sr is the sex ratio among her offspring.", Evaluatable->False, AspectRatioFixed->True], StyleBox[" f[]", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox[" is the ", Evaluatable->False, AspectRatioFixed->True], StyleBox["number", Evaluatable->False, AspectRatioFixed->True, FontSlant->"Italic"], StyleBox[ " of female offspring with 0, 1 and 2 A genes produced by the patch. (", Evaluatable->False, AspectRatioFixed->True], StyleBox["f", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox[ " should be multiplied by N, the total number of offspring produced by each \ foundress, but this cancels later and can be ignored.) ", Evaluatable->False, AspectRatioFixed->True], StyleBox["m[] ", Evaluatable->False, AspectRatioFixed->True, FontWeight->"Bold"], StyleBox["is the ", Evaluatable->False, AspectRatioFixed->True], StyleBox["proportion", Evaluatable->False, AspectRatioFixed->True, FontSlant->"Italic"], StyleBox[ " of males with 0 or 1 A genes produced by the patch. Random mating within \ the patch then produces the result returned by the function. ", Evaluatable->False, AspectRatioFixed->True] }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "output[k_]:=Module[{i,j,a,b},\n\t\tj=If[EvenQ[k],0,1];\n\t\ti=(k-j)/2;\n\t\t\ sr=If[i==0,r,s];\n\t\tf[0]=(n-1)(1-r)+(1-sr)(1-j)(1-i/2);\n\t\t\ f[1]=(1-sr)(j(1-i/2)+(1-j)i/2);\n\t\tf[2]=(1-sr)j i/2;\n\t\tm[1]=(sr \ i/2)/((n-1)r + sr);\n\t\tm[0]=1-m[1];\n\t\tRest[Flatten[Table[f[a] \ m[b],{a,0,2},{b,0,1}]]]]"], "Input", AspectRatioFixed->True], Cell[TextData[{ StyleBox["N output[k] p", Evaluatable->False, AspectRatioFixed->True], StyleBox["k", Evaluatable->False, AspectRatioFixed->True, FontVariations->{"CompatibilityType"->"Subscript"}], StyleBox[ "(t) gives the number of mated females of different mutant types produced \ by patches of type k in generation t. Dividing by Nn(1-r), which is to first \ order the total number of mated females produced, gives the relative \ frequency of the different mutant types of mated female produced by patches \ of type k. This must be multiplied by n to give the relative frequency of \ patches of different mutant types in the next generation whose mutant \ foundress came from a patch of type k in this generation (since each such \ patch contains 1 mutant foundress in a group of n foundresses). Thus \ output[k]/(1-r) is the kth column in the transition matrix. We calculate this \ matrix as:", Evaluatable->False, AspectRatioFixed->True] }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["A=Transpose[Table[output[k]/(1-r),{k,5}]];"], "Input", AspectRatioFixed->True], Cell[TextData[ "We now use Equation 10.6 to find the unbeatable sex ratio:"], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["deriv=Simplify[D[Det[A-IdentityMatrix[5]],s]/.s->r]"], "Input", AspectRatioFixed->True], Cell[TextData["ans=r/.Solve[deriv==0,r]"], "Input", AspectRatioFixed->True], Cell[TextData["Factor[Numerator[ans]]/Factor[Denominator[ans]] "], "Input", AspectRatioFixed->True]}, Open]]}, Open]], Cell[CellGroupData[{Cell[TextData["10"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["See the solution to Exercise 3."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["11"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[{ StyleBox["Define ", Evaluatable->False, AspectRatioFixed->True], StyleBox["\[Alpha]", Evaluatable->False, AspectRatioFixed->True], StyleBox[ " in Equation 43 as a function of the list of sex ratios in the three \ patches, r. (The relative frequencies of the patches can be ignored since \ they are equally frequent.)", Evaluatable->False, AspectRatioFixed->True] }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "wmale={1,1,1};\nwfemale={1,2,3};\nrho=wmale/wfemale;\n\ alpha[r_List]:=wmale.r/(wfemale.(1-r))"], "Input", AspectRatioFixed->True], Cell[TextData[ "Solve Equation 43 for the optimal sex ratio in the switch patch, assuming in \ turn that this is the first, second and third patch. See which assumption \ gives a legitimate answer."], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["r={x,0,0};\nSolve[alpha[r]==rho[[1]],x]"], "Input", AspectRatioFixed->True], Cell[TextData["r={1,x,0};\nSolve[alpha[r]==rho[[2]],x]"], "Input", AspectRatioFixed->True], Cell[TextData["r={1,1,x};\nSolve[alpha[r]==rho[[3]],x]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["12"], "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["Use pencil and paper."], "Text", Evaluatable->False, AspectRatioFixed->True]}, Open]]}, Open]] }, FrontEndVersion->"Macintosh 3.0", ScreenRectangle->{{0, 640}, {0, 460}}, WindowToolbars->{}, CellGrouping->Manual, WindowSize->{520, 365}, WindowMargins->{{52, Automatic}, {Automatic, 16}}, PrivateNotebookOptions->{"ColorPalette"->{RGBColor, -1}}, ShowCellLabel->True, ShowCellTags->False, RenderingOptions->{"ObjectDithering"->True, "RasterDithering"->False}, MacintoshSystemPageSetup->"\<\ AVU/IFiQKFD000000V:^/09R]g0000000OVaH097bCP0AP1Y06`0I@1^0642HZj` 0V:gT0000001nK500TO9>000000000000000009R[[0000000000000000000000 00000000000000000000000000000000\>" ] (*********************************************************************** 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[1731, 51, 87, 2, 70, "Section", Evaluatable->False], Cell[CellGroupData[{ Cell[1841, 55, 81, 2, 70, "Subsection", Evaluatable->False], Cell[1925, 59, 150, 4, 70, "Text", Evaluatable->False], Cell[2078, 65, 103, 1, 70, "Input"], Cell[2184, 68, 91, 1, 70, "Input"], Cell[2278, 71, 85, 1, 70, "Input"], Cell[2366, 74, 98, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[2496, 77, 81, 2, 70, "Subsection", Evaluatable->False], Cell[CellGroupData[{ Cell[2600, 81, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[2688, 85, 984, 32, 70, "Text", Evaluatable->False], Cell[3675, 119, 79, 1, 70, "Input"], Cell[3757, 122, 64, 1, 70, "Input"], Cell[3824, 125, 67, 1, 70, "Input"], Cell[3894, 128, 64, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[3990, 131, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[4078, 135, 94, 1, 70, "Input"], Cell[4175, 138, 66, 1, 70, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[4282, 141, 81, 2, 70, "Subsection", Evaluatable->False], Cell[4366, 145, 212, 4, 70, "Text", Evaluatable->False], Cell[4581, 151, 89, 1, 70, "Input"], Cell[4673, 154, 77, 1, 70, "Input"], Cell[4753, 157, 80, 1, 70, "Input"], Cell[4836, 160, 89, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[4957, 163, 81, 2, 70, "Subsection", Evaluatable->False], Cell[5041, 167, 392, 14, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[5465, 183, 81, 2, 70, "Subsection", Evaluatable->False], Cell[5549, 187, 424, 7, 70, "Text", Evaluatable->False], Cell[5976, 196, 214, 4, 70, "Input"], Cell[6193, 202, 304, 6, 70, "Text", Evaluatable->False], Cell[6500, 210, 249, 5, 70, "Input"], Cell[6752, 217, 143, 4, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[6927, 223, 84, 2, 70, "Subsection", Evaluatable->False], Cell[7014, 227, 95, 2, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[7141, 231, 81, 2, 70, "Subsection", Evaluatable->False], Cell[CellGroupData[{ Cell[7245, 235, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[7333, 239, 95, 2, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[7460, 243, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[7548, 247, 105, 2, 70, "Text", Evaluatable->False] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[7694, 251, 81, 2, 70, "Subsection", Evaluatable->False], Cell[CellGroupData[{ Cell[7798, 255, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[7886, 259, 95, 2, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[8013, 263, 85, 2, 70, "Subsubsection", Evaluatable->False], Cell[8101, 267, 3271, 81, 70, "Text", Evaluatable->False], Cell[11375, 350, 361, 6, 70, "Input"], Cell[11739, 358, 1039, 23, 70, "Text", Evaluatable->False], Cell[12781, 383, 95, 1, 70, "Input"], Cell[12879, 386, 133, 3, 70, "Text", Evaluatable->False], Cell[13015, 391, 104, 1, 70, "Input"], Cell[13122, 394, 77, 1, 70, "Input"], Cell[13202, 397, 101, 1, 70, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[13344, 400, 82, 2, 70, "Subsection", Evaluatable->False], Cell[13429, 404, 105, 2, 70, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[13566, 408, 82, 2, 70, "Subsection", Evaluatable->False], Cell[13651, 412, 470, 15, 70, "Text", Evaluatable->False], Cell[14124, 429, 148, 3, 70, "Input"], Cell[14275, 434, 256, 5, 70, "Text", Evaluatable->False], Cell[14534, 441, 92, 1, 70, "Input"], Cell[14629, 444, 92, 1, 70, "Input"], Cell[14724, 447, 92, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[14848, 450, 82, 2, 70, "Subsection", Evaluatable->False], Cell[14933, 454, 95, 2, 70, "Text", Evaluatable->False] }, Closed]] }, Open ]] } ] *) (*********************************************************************** End of Mathematica Notebook file. ***********************************************************************)