(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "Macintosh Mathematica Notebook Front End Version 2.2"; MacintoshStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e8, 24, "Times"; fontset = subtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6, 18, "Times"; fontset = subsubtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, e6, 14, "Times"; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, a20, 18, "Times"; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, a15, 14, "Times"; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, a12, 12, "Times"; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L-5, 12, "Courier"; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, R65535, L-5, 12, "Courier"; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, B65535, L-5, 12, "Courier"; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, 12, "Courier"; fontset = name, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, 10, "Geneva"; fontset = header, inactive, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = leftheader, inactive, L2, 12, "Times"; fontset = footer, inactive, noKeepOnOnePage, preserveAspect, center, M7, 12, "Times"; fontset = leftfooter, inactive, L2, 12, "Times"; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; paletteColors = 128; automaticGrouping; currentKernel; ] :[font = section; inactive; preserveAspect; startGroup] CHAPTER 12 :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 1 :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 1a :[font = text; inactive; preserveAspect] Define the fitness function, plot it for m2=0.05, and evaluate it for m1=0.01, m2=0.05. These calculations establish that when m2=0.05 the optimal value of m1 is about 1. Repeating this exercise for different values of m2 will show that the optimal value of m1 is 0.01 when m2 > 0.15 and is at an internal optimum with m1 round about unity when m2 < 0.05. :[font = input; preserveAspect] w[m1_,m2_]:=100(1-Exp[-(m1+m2)^2])/m1 :[font = input; preserveAspect] Plot[w[m1,.05],{m1,.01,2}] :[font = input; preserveAspect] w[.01,.05] :[font = text; inactive; preserveAspect] We now find the optimal value of m1 when m2=0.01: :[font = input; preserveAspect; endGroup] f[m1_,m2_]=D[w[m1,m2],m1]; FindRoot[f[m1,.01]==0,{m1,1}] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 1b :[font = text; inactive; preserveAspect; endGroup; endGroup] See Exercise 1a. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 2 :[font = text; inactive; preserveAspect] I define the recurrence relation, find the equilibrium values, and the stability criteria: :[font = input; preserveAspect] f[p_]:=(1-s)p(2-p)/(1-s p(2-p)) :[font = input; preserveAspect] equil=Solve[f[p]==p,p] :[font = input; preserveAspect] Simplify[D[f[p],p]/.equil] :[font = text; inactive; preserveAspect] I simulate the system with s = 0.25: :[font = input; preserveAspect] s=.25; :[font = input; preserveAspect] sim=NestList[f,.1,25]; :[font = input; preserveAspect; endGroup] ListPlot[sim] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 3 :[font = text; inactive; preserveAspect] Define the recurrence relation in Equation 8 and set s = 0.25: :[font = input; preserveAspect] f[x_]:=(a=x[[1]];b=x[[2]];c=x[[3]];d=x[[4]]; y={(1-s)(a-0.5a d+b c), (1-s)(b+0.5a d+b d), (c+0.5a d-b c), (d-0.5a d-b d)}; y/Apply[Plus,y]) :[font = input; preserveAspect] s=0.25; :[font = text; inactive; preserveAspect] I first calculate the effect of one round of infection as described in the text, and show that after 20 generations virtually all individuals are infected but the frequency of uniparental individuals has increased from 0.010 to 0.013: :[font = input; preserveAspect] x={0,0,.01,.99}; x={.01x[[3]],.01x[[4]],.99x[[3]],.99x[[4]]}; res=NestList[f,x,20]; :[font = input; preserveAspect] res//TableForm :[font = text; inactive; preserveAspect] I now write two programs. The first, called rep takes the existing value of x and iterates a further 20 generations. The second one, called new transfers all the infected individuals to the uninfected class and introduces a new infection. ;[s] 7:0,0;44,1;47,0;76,1;77,0;140,1;143,0;239,-1; 2:4,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0; :[font = input; preserveAspect] rep:=(x=Nest[f,x,20]) :[font = input; preserveAspect] new:=(x={0,0,x[[1]]+x[[3]],x[[2]]+x[[4]]}; x={.01x[[3]],.01x[[4]],.99x[[3]],.99x[[4]]}) :[font = text; inactive; preserveAspect] Start with x={0,0,.01,.99} and simulate the introduction of successive new infections by using new; follow each infection by repeatedly using rep until virtually all individuals are either infected (x1 + x2 = 1) or uninfected (x3 + x4 = 1): ;[s] 5:0,0;95,1;98,0;142,1;145,0;241,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = input; preserveAspect] x={0,0,.01,.99}; :[font = input; preserveAspect] new :[font = input; preserveAspect] rep :[font = input; preserveAspect] new :[font = input; preserveAspect] rep :[font = text; inactive; preserveAspect; endGroup] and so on. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 4 :[font = text; inactive; preserveAspect] The transition matrix is :[font = input; preserveAspect] A={{p/(1-r)+(1-p)/2,1/2},{(1-p)/2,1/2}}; :[font = text; inactive; preserveAspect] Find its eigenvalues and evaluate them for p = 1 and for p small: :[font = input; preserveAspect] eigen=Eigenvalues[A]; :[font = input; preserveAspect] PowerExpand[Simplify[eigen/.p->1]] :[font = input; preserveAspect; endGroup] PowerExpand[Simplify[Series[eigen,{p,0,1}]]] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 5 :[font = text; inactive; preserveAspect; endGroup] Define the matrix and evaluate its eigenvalues. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 6 :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 6a :[font = text; inactive; preserveAspect] Define the Poisson distribution and evaluate it with mean = 15: :[font = input; preserveAspect] Poisson[x_,m_]:=Exp[-m] (m^x)/x! :[font = input; preserveAspect; endGroup] Table[{x,10^7 Poisson[x,15.]},{x,0,50}]//TableForm :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 6b :[font = text; inactive; preserveAspect] Define the recursion for q[t,a] from Equations 20 and 21 and evaluate q for the appropriate values of the arguments: ;[s] 5:0,0;25,1;31,0;70,1;71,0;117,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = input; preserveAspect] q[t_,1]:=q[t,1]=Exp[q[t-1,1]-1] q[0,1]=0.0; q[t_,a_]:=(q[t,1])^a :[font = input; preserveAspect] Do[q[t,1],{t,2000}] :[font = input; preserveAspect] tvals={1,2,5,10,20,40,100}; :[font = input; preserveAspect; endGroup; endGroup] Table[{t=tvals[[i]],q[t,1],q[5t,5],q[10t,10],q[20t,20]}, {i,Length[tvals]}]//TableForm :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 7 :[font = text; inactive; preserveAspect] I give some functions for calculating the relative advantage of sex under truncation selection. mu[lambda,k] calculates m as a function of l and k from Equation 12.29. sexad[U,k,approx] finds the relative advantage of sex from Equations 12.28, 30 and 31; it requires an approximate value for l which must be obtained first (see example). Use sexad to verify the advantage of sex for the parameter values in Table 12.3. (The calculations for large values of k are time-consuming.) ;[s] 14:0,0;97,1;110,0;121,3;122,2;123,0;140,3;142,0;169,1;188,0;294,3;295,0;344,1;349,0;482,-1; 4:7,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0;1,18,13,Symbol,1,12,0,0,0;3,18,13,Symbol,0,12,0,0,0; :[font = input; preserveAspect] mu[lambda_,k_]:= Sum[lambda^i/(i-1)!,{i,k-1}]/Sum[lambda^i/i!,{i,0,k-1}] :[font = input; preserveAspect] sexad[U_,k_,approx_]:=Exp[U-lambda] Sum[lambda^i/i!, {i,0,k-1}] /. FindRoot[lambda==mu[lambda,k]+U, {lambda,approx}] :[font = text; inactive; preserveAspect] An example with U = 0.5, k = 5: :[font = input; preserveAspect] Plot[x-mu[x,5]-0.5,{x,0.5,5}] :[font = input; preserveAspect; endGroup] sexad[0.5,5,2.8] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 8 :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 8a :[font = text; inactive; preserveAspect; endGroup] Use pencil and paper. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 8b :[font = text; inactive; preserveAspect] Define the continuous-time transition matrix and find its equilibria and their stability criteria in the standard way. :[font = input; preserveAspect] Clear[f,s] :[font = input; preserveAspect] f[1][s1_,s2_]:=s1((10^-4)(100-s1-s2)-10^-4)/100 f[2][s1_,s2_]:=s2((10^-4)(100-s1-s2)- 2 10^-4)/100 :[font = input; preserveAspect] equil=Solve[f[1][s[1],s[2]]==f[2][s[1],s[2]]==0,{s[1],s[2]}] :[font = input; preserveAspect] jac=Table[D[f[i][s[1],s[2]],s[j]],{i,2},{j,2}]; :[font = input; preserveAspect; endGroup; endGroup] Eigenvalues[jac]/.equil//N :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 9 :[font = text; inactive; preserveAspect] Define b(x) and then follow the exercise. ;[s] 3:0,0;7,1;8,0;42,-1; 2:2,13,9,Times,0,12,0,0,0;1,18,13,Symbol,0,12,0,0,0; :[font = input; preserveAspect] beta[x_]:=1.582(1-Exp[x-1]) :[font = input; preserveAspect] Plot[beta[1-x],{x,0,1}] :[font = input; preserveAspect] Plot[x+beta[x],{x,0,1}] :[font = input; preserveAspect] f=(1/x)+(D[beta[x],x]/beta[x]); xstar=x/.FindRoot[f==0,{x,.5}] :[font = input; preserveAspect; endGroup] beta[xstar] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 10 :[font = text; inactive; preserveAspect; endGroup; endGroup] Use pencil and paper. ^*)