This notebook provides the Mathematica code used to generate the numerical plots. Care must be used with numerical calculations of this kind, as they may be sensitive to the small differences between numbers that are equal up to machine precision. We believe that the numerics below are accurate, but the code will not necessarily work on parameters much larger or smaller than those considered here.

Definitions

Needs["PlotLegends`"]

goodlabel

goodlabel::usage="Evaluate[goodlabel[xlabel,ylabel, xstyle, ystyle]] makes plot labels with the desired style. Labels should be passed as strings.";
goodlabel[x_,y_]:={Frame->{{True,False},{True,False}},FrameLabel->{x,y}};
goodlabel[x_,y_,style_]:=goodlabel[x,y,style,style];goodlabel[x_,y_,xstyle_, ystyle_]:={Frame->{{True,False},{True,False}},FrameLabel->{Style[x,xstyle],Style[y,ystyle]}};

HaploidTypes

HaploidTypes::usage="HaploidTypes[{{a1,b1,..},{a2,b2,..}..}] lists all possible haploid genotypes, based on the set of alleles {a1,b1,..} at locus 1, etc.  HaploidTypes[{{a,b,..},n}] lists all possible genotypes, assuming the same set of alleles at n loci.  HaploidTypes[n] assumes n loci, with two alleles labelled {0,1}.";

HaploidTypes[{},___]:={};

HaploidTypes[g_List,opts___]:=HaploidTypes[g,opts]=
			Flatten[Apply[Outer,Prepend[g,List]],Length[g]-1];

HaploidTypes[{g_List,n_Integer},opts___]:=HaploidTypes[{g,n},opts]=HaploidTypes[Table[g,{n}],opts];

HaploidTypes[n_Integer,opts___]:=HaploidTypes[n,opts]=HaploidTypes[{{0,1},n},opts];

Logistic/logit functions

The logit function is the inverse of the logistic function.

Logistic[t_]:=1/(1+Exp[-t]);
Logit[p_]:=Log[(p/(1-p))];

RealPositiveQ

RealPositiveQ::usage="RealPositiveQ[{…}] tests whether every entry in a list is real and positive. This can be used as a sanity check in calculations.";

RealPositiveQ[s_List]:=And@@(Re[#1]>0&&Im[#1]==0&)/@s;

U, V -- single sweep trajectories

U::usage="U[T,S,Tc] gives the frequency of a deterministic sweep centered at Tc, with selective coefficient S. U[T,S] assumes Tc=0. U[T] assumes S=1.";

V::usage="V[T,S,Tc] gives the frequency of the original allele for a sweep centered at Tc, with selective coefficient S.  U[T,S] assumes Tc=0.";

V[T_,ST___]:=1-U[T,ST];
U[T_]:=U[T,1,0];
U[T_,S_]:=U[T,S,0];
U[T_,S_,Tc_]:=Logistic[S(T-Tc)];

One background sweep

These functions describe the fixation probability of a new favorable allele at a locus given that there is an ongoing sweep at a linked locus. This background sweep is assumed to be deterministic and uninfluenced by the focal allele. All variables are scaled. Let the advantage of the focal allele be s, the advantage of the background allele be S, and the recombination rate between the loci be r, and letting t be the number of generations from when the background sweep is at frequency 1/2 (so that t<0 corresponds to frequencies <1/2). The functions work with θ=s/S, ρ=r/S, T=S t, and return the scaled probability of fixation Φ=(Subscript[P, fix])/(2s). Note that these are the scalings used in Barton 1995, which are different from those used in the rest of this manuscript.

PfixNew

PfixNew::usage="PfixNew[{Pv,Pu},{θ,ρ},{T0,T1}] gives the scaled expected probability of fixation, Φ(X,T), of a new allele arising on background X. Pu(T)=Φ(1,T) is for an allele arising on the favorable background, while Pv(T)=Φ(0,T) is for the unfavorable background. Φ is calculated for a range of times T∈[T0,T1], where T1 should be late enough that the sweep is effectively fixed.";

PfixNew[{Pv_,Pu_},{θ_,ρ_},{T0_,T1_}]:=Module[{T},
NDSolve[{
-Pv '[T]==-ρ U[T](Pv[T]-Pu[T])+(θ-U[T])Pv[T]-θ ((Pv[T])^2),
-Pu '[T]==+ρ V[T](Pv[T]-Pu[T])+(θ+V[T])Pu[T]-θ ((Pu[T])^2),
Pv[T1]==((-1+θ-ρ+(Sqrt[4 θ ρ+(((1-θ+ρ))^2)]))/(2 θ)),Pu[T1]==1},{Pv,Pu},{T,T0,T1}][[1]]];

PfixTot

PfixTot::usage="PfixTot[{θ,ρ},{T0,T1}] gives the scaled total loss of fixation probability at the focal locus caused by interference from the background sweep, (∫_T0^T1)(1-(OverBar[Φ]))\[DifferentialD]T.";

PfixTot[{θ_,ρ_},{T0_,T1_}]:=PfixTot[{θ,ρ},{T0,T1}]=Module[{T,Pu,Pv,ss},
ss=PfixNew[{Pv,Pu},{θ,ρ},{T0,T1}];
NIntegrate[1-(((E^(-T))Pv[T]+Pu[T])/((E^(-T))+1))/.ss,{T,T0,T1}]];

Interference from multiple background sweeps

These functions describe the fixation probability of a new favorable allele at a locus given that there are ongoing sweeps at linked loci. These background sweeps are assumed to be deterministic and uninfluenced by the focal allele. PfixMany, Pbar, PfixManyTot, and recEqs assume that all background sweeps are in linkage equilibrium, while PfixManyLD and PfixManyTotLD allow linkage disequilibrium among the background alleles and assume that all the sweeping background alleles arose in the original ancestral background. (This is potentially problematic -- see the definition of Gsol in the section “Background genotype dynamics”.) PbarLD and recEqsLD allow linkage disequilibrium and make no assumption about the initial state of the background sweeps.

All variables are scaled  by the advantage of the focal allele, s. (Note that this is the standard scaling used in this manuscript, which is different from the scaling used above for a single background sweep.) Let (Subscript[A, i]) be the selective advantage of the (i^th) background allele and (Subscript[r, i]) be its map position relative to the focal locus (with r allowed to take both positive and negative values, so that the recombination rate is |(Subscript[r, i])|), and let t be the number of generations from some arbitrary time. The functions work with (Subscript[S, i])=(Subscript[A, i])/s, (Subscript[ρ, i])=(Subscript[r, i])/s, T=s t, and return quantities related to the scaled probability of fixation, Φ=(Subscript[P, fix])/(2s). Backgrounds are labeled by (UnderBar[X]), a binary vector with one entry for each background sweep, with (Subscript[X, i])=1 corresponding to the favorable background and (Subscript[X, i])=0 corresponding to the unfavorable one.

The functions in this section use the functions in the section “Background genotype dynamics”.

PfixMany

PfixMany::usage="PfixMany[P,{S_List,ρ_List,T_List},{Tmin,Tmax}] calculates the set of functions Φ((UnderBar[X]),T') of scaled fixation probabilities of new alleles arising on each background (UnderBar[X]). T_List is a list of the times at which each background allele reaches frequency 1/2. S_List and ρ_List are their scaled selective coefficients and scaled map positions relative to the focal locus. Φ is calculated for a range of T' from Tmin to Tmax, where Tmax should be late enough that all background sweeps are effectively fixed; the origin for time is arbitrary. All background sweeps are assumed to be in linkage equilibrium with each other.";

PfixMany[P_,{S_List,ρ_List,T_List},{Tmin_,Tmax_}]:=Module[{t,ul,v,eqs,bc,ht,vars},
ht=HaploidTypes[Length[S]];
vars=P@@#&/@ht;
ul=MapThread[U[t,#1,#2]&,{S,T}];
eqs=MapThread[(-#2'[t]==recEqs[P,t,#1,ρ,ul]+(1+(Plus@@(S(#1-ul))))#2[t]-((#2[t])^2))&,{ht,vars}];
bc=MapThread[(#2[Tmax]==Psol[#1,S,ρ])&,{ht,vars}];
NDSolve[Join[eqs,bc],vars,{t,Tmin,Tmax}][[1]]];

PfixManyLD

PfixManyLD::usage="PfixManyLD[{P,G},{{S1…},{ρ1…},{T1…}},{Tmin,Tmax}] generalizes PfixMany to allow for LD among the background sweeps. Variables are as in PfixMany, except that now T_List lists the scaled times at which the sweeps would have been at frequency 1/2 in the absence of interference. In addition to Φ((UnderBar[X]),T), PfixManyLD returns G((UnderBar[X]),T), the frequency of each background over time. All of the background sweeps are assumed to have started in the original ancestral background; see the definition of Gsol for possible issues with this.";

PfixManyLD[{P_,G_},{S_List,ρ_List,T_List},{Tmin_,Tmax_}]:=Module[{t,v,eqs,bc,ht,vars,gs,wb,n=Length[S]},
gs=Gsol[G,{S,ρ,T},{Tmin,Tmax}];
ht=HaploidTypes[Length[S]];
vars=P@@#&/@ht;
wb=S.MarginalU[G,t,n]/.gs;
eqs=MapThread[(-#2'[t]==recEqsLD[P,t,#1,ρ,G]+(1+((S.#1)-wb))#2[t]-((#2[t])^2))&,{ht,vars}]/.gs;
bc=MapThread[(#2[Tmax]==Psol[#1,S,ρ])&,{ht,vars}];
Join[NDSolve[Join[eqs,bc],vars,{t,Tmin,Tmax}][[1]],gs]];

Pbar

Pbar::usage="Pbar[P,t,{(Subscript[u, 1]),…}] calculates the scaled mean fixation probability, (OverBar[Φ])(T), from Φ((UnderBar[X]),T) and the background allele frequencies (Subscript[U, i])(T), assuming that the background sweeps are in linkage equilibrium.  Pbar[P,t,{(Subscript[s, 1]),…},{(Subscript[t, 1]),…}] first calculates (Subscript[U, i])(T) from the scaled selective coefficients of the background loci and the times at which each reaches frequency 1/2.";

Pbar[P_,t_,ul_List]:=Plus@@((Times@@(ul#+(1-#)(1-ul))((P@@#)[t]))&/@HaploidTypes[Length[ul]]);

Pbar[P_,t_,sl_List,tl_List]:=Pbar[P,t,MapThread[U[t,#1,#2]&,{sl,tl}]];

PbarLD

PbarLD::usage="Pbar[{P,G},t,n] calculates the scaled mean fixation probability, (OverBar[Φ])(T), from Φ((UnderBar[X]),T) and the background genotype frequencies G((UnderBar[X]),T).";

PbarLD[{P_,G_},t_,n_Integer]:=Plus@@((((G@@#)[t])((P@@#)[t]))&/@HaploidTypes[n]);

PfixManyTot

PfixManyTot::usage="PfixManyTot[{{S1…},{ρ1…},{T1…}},{Tmin,Tmax}] gives the scaled total loss of fixation probability at a locus due to multiple sweeps in linkage equilibrium, (∫_Tmin^Tmax)(1-(OverBar[Φ])(T))\[DifferentialD]T. Variables are as in PfixMany. Plot->True plots a graph of scaled mean fixation probability and of the background allele frequencies over time.";

Options[PfixManyTot]={Plot->False};

PfixManyTot[{S_List,ρ_List,T_List},{Tmin_,Tmax_},opts___Rule]:=Module[{sol,t,P,ul,optsPlot,gr},
sol=PfixMany[P,{S,ρ,T},{Tmin,Tmax}];
If[Plot/.{opts}/.Options[PfixManyTot],
ul=MapThread[U[t,#1,#2]&,{S,T}];
optsPlot=FilterOptions[Plot,opts];
gr=Plot[Append[ul,Pbar[P,t,S,T]/.sol]//Evaluate,{t,Tmin,Tmax},optsPlot//Evaluate]];
{gr,NIntegrate[1-Pbar[P,t,S,T]/.sol,{t,Tmin,Tmax}]}];

PfixManyTotLD

PfixManyTotLD::usage="PfixManyTotLD[{{S1…},{ρ1…},{T1…}},{Tmin,Tmax}] generalizes PfixManyTot to allow for LD among the background alleles. Variables are as in PfixManyLD. All of the background sweeps are assumed to have started in the original ancestral background; see the definition of Gsol for possible issues with this.";

Options[PfixManyTotLD]={Plot->False};

PfixManyTotLD[{S_List,ρ_List,T_List},{Tmin_,Tmax_},opts___Rule]:=Module[{sol,t,P,G,optsPlot,ul,n=Length[S],gr},
sol=PfixManyLD[{P,G},{S,ρ,T},{Tmin,Tmax}];
ul=MarginalU[G,t,n]/.sol;
If[Plot/.{opts}/.Options[PfixManyTot],
optsPlot=FilterOptions[Plot,opts];
gr=Plot[Append[ul,PbarLD[{P,G},t,n]/.sol]//Evaluate,{t,Tmin,Tmax},optsPlot//Evaluate]];
{gr,NIntegrate[1-PbarLD[{P,G},t,n]/.sol//Evaluate,{t,Tmin,Tmax}]}];

Psol

Psol::usage="Psol[(UnderBar[X]),{(Subscript[S, 1]),…},{(Subscript[ρ, 1]),…}] gives the value of Φ((UnderBar[X])) assuming that all sweeping background alleles are nearly fixed. Variables are as in PfixMany.";

Psol[X_List,sl_List,rl_List]:=Module[{j,rs,rt,st,k=Length[Select[rl,#>0&]],n=Length[rl],Y},
If[MatchQ[X,{(1)..}],1,
st=sl.(1-X);
rt=Sum[If[MatchQ[Take[X,-j],{(1)..}],0,(rl[[-j]]-If[j==k,0,rl[[-j-1]]])],{j,k}]+
Sum[If[MatchQ[Take[X,j],{(1)..}],0,(If[j==n-k,0,rl[[j+1]]]-rl[[j]])],{j,n-k}];
rs=Sum[If[MatchQ[Take[X,-j],{(1)..}],0,
(Y=Join[Drop[X,-j],Array[1&,j]];
(rl[[-j]]-If[j==k,0,rl[[-j-1]]])Psol[Y,sl,rl])],{j,k}]+
Sum[If[MatchQ[Take[X,j],{(1)..}],0,
Y=Join[Array[1&,j],Drop[X,j]];
(If[j==n-k,0,rl[[j+1]]]-rl[[j]])Psol[Y,sl,rl]],{j,n-k}];
(1/2)(1-rt-st+(Sqrt[4rs+(((1-rt-st))^2)]))]];

recEqs

recEqs::usage="recEqs[P,t,{0,…},{ρ1,…},{u1,…}] gives the terms involving recombination between the focal locus and the background loci in the equations for scaled fixation probability, Φ (Eq. 4 in the main text), assuming that all background sweeps are in linkage equilibrium, so that they can be described by their allele frequencies, (Subscript[U, i]). recEqs[P,{0,…},{ρ1,…}] assumes that all sweeping background alleles are nearly fixed.";

recEqs[P_,t_,gl_List,rl_List,ul_List]:=Module[{j,h,uplus,k=Length[Select[rl,#>0&]],n=Length[rl]},
Sum[(
h=DeleteCases[HaploidTypes[j],Take[gl,-j]];
uplus=Take[ul,-j];
-(rl[[-j]]-If[j==k,0,rl[[-j-1]]])(Plus@@((Times@@(uplus(2#-1)+(1-#)))((P@@gl)[t]-(P@@(Join[Drop[gl,-j],#]))[t])&/@h))),{j,k}]+
Sum[(
h=DeleteCases[HaploidTypes[j],Take[gl,j]];
uplus=Take[ul,j];
-(If[j==n-k,0,rl[[j+1]]]-rl[[j]])(Plus@@((Times@@(uplus(2#-1)+(1-#)))((P@@gl)[t]-(P@@(Join[#,Drop[gl,j]]))[t])&/@h))),{j,n-k}]];

recEqs[P_,gl_List,rl_List]:=Module[{j,h,k=Length[Select[rl,#>0&]],n=Length[rl]},
Sum[(
h=Array[1&,j];
-(rl[[-j]]-If[j==k,0,rl[[-j-1]]])((P@@gl)-((P@@(Join[Drop[gl,-j],h]))))),{j,k}]+
Sum[(
h=Array[1&,j];
-(If[j==n-k,0,rl[[j+1]]]-rl[[j]])((P@@gl)-((P@@(Join[h,Drop[gl,j]]))))),{j,n-k}]];

recEqsLD

recEqsLD::usage="recEqsLD[P,t,{0,…},{ρ1,…},g] gives the terms involving recombination in the equations for the scaled fixation probability, Φ, (Eq. 4 in the main text) in terms of the background genotype frequencies g[(UnderBar[X])][t], allowing for linkage disequilibrium.";

recEqsLD[P_,t_,gl_List,rl_List,gg_]:=Module[{j,h,k=Length[Select[rl,#>0&]],n=Length[rl]},
Sum[(
h=DeleteCases[HaploidTypes[j],Take[gl,-j]];
-(rl[[-j]]-If[j==k,0,rl[[-j-1]]])(Plus@@(((gg@@Join[Drop[gl,-j],#])[t])((P@@gl)[t]-(P@@(Join[Drop[gl,-j],#]))[t])&/@h))),{j,k}]+
Sum[(
h=DeleteCases[HaploidTypes[j],Take[gl,j]];
-(If[j==n-k,0,rl[[j+1]]]-rl[[j]])(Plus@@(((gg@@Join[#,Drop[gl,j]])[t])((P@@gl)[t]-(P@@(Join[#,Drop[gl,j]]))[t])&/@h))),{j,n-k}]];

Background genotype dynamics

These functions give the dynamics for sweeps at multiple background loci, and are called by functions in the section “Interference from multiple background sweeps”.

recEqsSel

recEqsSel::usage="recEqsSel[g,t,{0,…},{ρ1,…}] gives the terms involving recombination in the equations for genotype frequencies, g (Eq. 23 in Text S3).";

recEqsSel[g_,t_,gl_List,rl_List]:=Module[{j,n=Length[rl]},
Sum[(
-(rl[[j+1]]-rl[[j]])((g@@gl)[t]-((Plus@@(((g@@Join[Take[gl,j],#])[t])&/@HaploidTypes[n-j]))(Plus@@(((g@@Join[#,Take[gl,-(n-j)]])[t])&/@HaploidTypes[j]))))),{j,n-1}]];

xx=Plus@@(recEqsSel[g,t,#,{r1,r2,r3,r4}]&/@HaploidTypes[4])/.g[1,1,1,1][t]->1-(Plus@@((g@@#)[t]&/@DeleteCases[HaploidTypes[4],{1,1,1,1}]))//Simplify

Gsol

Gsol::usage="Gsol[g,{{(Subscript[S, 1]),…},{(Subscript[ρ, 1]),…},{(Subscript[T, 1]),…}},{Tmin,Tmax}] gives the genotype frequencies of a set of deterministic sweeps in the form g[0,0,…][t] (Eq. 23 in Text S3).  Initial genotype frequencies are defined by assuming that the sweep would pass through 0.5 at (Subscript[T, i]), in the absence of interference.  All favourable alleles arise on the same ancestral background, and so all are competing with each other.  It is important to check that all these alleles are rare at the beginning of the time period. In particular, they must be rare enough that it is roughly accurate to assume that there are no individuals with multiple sweeping alleles. There are known numerical issues for background loci with scaled recombination rates greater than 1.";

Gsol::badInit="Bad initial conditions: initial allele frequencies `1` sum to more than 1";

Gsol[g_,{S_List,ρ_List,T_List},{tmin_,tmax_}]:=Module[{t,ht,n=Length[S],eqs,vars,bc,ul,wb,init,u0},
ht=HaploidTypes[n];vars=g@@#&/@ht;
ul=MarginalU[g,t,n];
u0=1/(1+Exp[-S(tmin-T)]);
init=If[1==(Plus@@#),u0[[Position[#, 1][[1,1]]]],0]&/@HaploidTypes[n];
init=ReplacePart[init, 1-Plus@@init, 1];(*Normalize by removing them from the ancestral type*)
If[init[[1]]<0,Message[Gsol::badInit,u0]];
wb=S.ul;
eqs=MapThread[(#2'[t]==recEqsSel[g,t,#1,ρ]+((S.#1)-wb)#2[t])&,{ht,vars}];
bc=MapThread[(#2[tmin]==#1)&,{init,vars}];
NDSolve[Join[eqs,bc],vars,{t,tmin,tmax},MaxStepSize->.01][[1]]];

MarginalU

MarginalU::usage="MarginalU[g,t,n] gives the allele frequencies for n loci in terms of the genotype frequencies g[0,0,…][t].";

MarginalU[g_,t_,n_Integer]:=Module[{i},
If[n==1,{g[1][t]},
Table[Plus@@((g@@Join[Take[#,i-1],{1},Take[#,-(n-i)]])[t]&/@HaploidTypes[n-1]),{i,n}]]];

Figure 1: A selective sweep causes interference over a time ∼ 1/s and a genetic distance ∼ s.

Choose a grid of r and t values around the sweep:

rvals=Module[{lr},Table[Exp[lr],{lr,-6,3,.2}]];

tvals=Range[-10,10,.3];

Evaluate the average fixation probability at the grid points:

omegaofr=Module[{T0=-15,T1=15},PfixNew[{Pv,Pu},{1,#},{T0,T1}]&/@ rvals];

omegavals=Table[U[T]Pu[T]+V[T]Pv[T]/.omegaofr[[i]],{i,Length[rvals]},{T,tvals}];

Plot the result:

scaling[p_]:=1.2Logistic[15(p-.9)]

With[{levels=100},ShowLegend[Show[ListContourPlot[Flatten[Table[{{rvals[[i]],tvals[[j]],omegavals[[i,j]]},{-rvals[[i]],tvals[[j]],omegavals[[i,j]]}},{i,Length[rvals]},{j,Length[tvals]}],2],Contours->Table[1-i/(levels*2),{i,levels}],ContourStyle->None,PlotRange->{{-5,5},{-8,5},Full},ColorFunctionScaling->False,ColorFunction->Function[z,ColorData["SiennaTones"][scaling[z]]],Evaluate[goodlabel["Scaled genetic distance, r/s", "Scaled time, st",20]],FrameTicksStyle->Directive[Black,16]],Graphics[Inset[Style["×",18],{0,-Log[1000]},Center]]],{Table[{ColorData["SiennaTones"][scaling[Max[omegavals]-i (Max[omegavals]-Min[omegavals])/levels]],If[Mod[i,20]==0,Style[" "<>ToString[N[1-i/(2*levels)]]<>"   ",{Black,14}],""]},{i,0,levels}],LegendPosition->{-.8,1},LegendOrientation->Horizontal,LegendShadow->False,LegendSize->{1.8,.3},LegendLabel->Style["Scaled probability of fixation, (Subscript[P, fix])/2s\n",{16,Black}],LegendBorderSpace->2,LegendSpacing->0}]]

Figure S3: Interference caused by a single sweep over time.

Plot the loss of fixation probability over time for a range of recombination rates:

Module[{T0=-15,T1=15},
LogPlot[{1-(U[T]Pu[T]+V[T]Pv[T])/.PfixNew[{Pv,Pu},{1,0.001},{T0,T1}],
1-(U[T]Pu[T]+V[T]Pv[T])/.PfixNew[{Pv,Pu},{1,0.01},{T0,T1}],
1-(U[T]Pu[T]+V[T]Pv[T])/.PfixNew[{Pv,Pu},{1,0.1},{T0,T1}],
1-(U[T]Pu[T]+V[T]Pv[T])/.PfixNew[{Pv,Pu},{1,1},{T0,T1}],1-(U[T]Pu[T]+V[T]Pv[T])/.PfixNew[{Pv,Pu},{1,10},{T0,T1}]},{T,T0,T1},
PlotRange->{{T0,10},{0,1}},Epilog->Inset[Style["(Subscript[Log, 10])[r/s] =",14]Style[Table[Style[i-4,markerSymbols[5][[i,1]]],{i,5}],14],{-1,-17}],Evaluate[goodlabel["Scaled time, st","Scaled loss of fixation probability, (Subscript[Ω, 1])/2s",14]]]]

Figure S4: Total interference caused by a single sweep at different genetic distances.

Module[{T0=-15,T1=15},Show[ListLogLogPlot[Table[{Exp[lρ],PfixTot[{1,Exp[lρ]},{T0,T1}]}(*points*),{lρ,Log[.005],Log[1000],.5}]],LogLogPlot[{PfixTot[{1,1},{T0,T1}]/ρ(*blue line*),
PfixTot[{1,(10^3)},{T0,T1}]/(((ρ/(10^3)))^2)(*purple line*)},{ρ,.1,(10^3)}],Evaluate[goodlabel["Scaled map distance, r/s", "Net loss of fixation probability, ∫(Subscript[Ω, 1])[r,t]\[DifferentialD]t",14]]]]

Figure S5: Reduction in fixation probability due to a pair of sweeps.

Pair of sweeps: Effect on the locus midway between them

Find the loss in fixation probability due to a single sweep:

tblOmega1=Module[{rho},Table[{rho,PfixManyTot[{{1},{rho},{0}},{Logit[1/(10^5)],25}][[2]]},{rho,{.0001,.001,.01,.1,1,10}}]];

Define a function for finding the loss in fixation probability due to a pair of sweeps in linkage equilibrium (“ple”), and due to a pair that start in complete linkage disequlibrium (“pf”):

tblOmega2[ρ_,{dtm_,dtd_},n_]:=Module[{g,dt,t,ple,pf},
Table[
ple=PfixManyTot[{{1,1},{-ρ,ρ},{0,dt}},{Logit[1/n],25}];
pf=PfixManyTotLD[{{1,1},{-ρ,ρ},{0,dt}},{Logit[1/n],25}];
{dt,ple[[2]],pf[[2]]},{dt,0,dtm,dtd}]];

Apply it to the parameters we want to plot:

omega2PlotTable=Module[{rho},Flatten[Table[{Partition[Riffle[#[[All,1]],#[[All,2]]],2],Partition[Riffle[#[[All,1]],#[[All,3]]],2]}&[tblOmega2[rho,{5,.5},(10^5)]],{rho,{.0001,.001,.01,.1,1}}],1]];

Average over the possible time intervals between the sweeps:

omega2aves=Mean[#[[All,2]]]&/@omega2PlotTable;

o2avePlotTable=Module[{rhos=10^Range[-4,0]},{Transpose[{rhos,omega2aves[[2Range[5]]]}],Transpose[{rhos,omega2aves[[-1+2Range[5]]]}]}];

Pairs of sweeps: total effect over the whole genome

Total loss of fixation probability caused over the whole genome, as a function of the separation between the pair of sweeps, for sweeps that start in complete LD and sweeps in linkage equilibrium:

Summary:
({{r/s, ∫Ω dr/s, ∫Ω dr/s LE}, {1, 4.799, 4.221}, {0.1, 4.449, 4.305}, {0.01, 4.348, 4.307}, {0.001, 4.222, 4.193}, {0.0001, 4.160, 4.159}})

xl=Join[Range[0.5,0.95,0.05],Range[0.955,0.995,0.005],Range[0.9955,0.99995,0.0005],
Range[1.0005,1.005,0.0005],Range[1.01,1.05,0.005],Range[1.1,2,0.05],Range[2.2,5,0.2],Range[6,20],Range[25,100,5],Range[200,1000,50]];

xl2=Join[xl,Range[1500,10000,500],Range[12000,40000,2000]];
xl3=Join[xl2,Range[50000,100000,10000],Range[150000,300000,50000]];

ρ=1 (with LD)

rr=1;dt=0;
rt2[rr,dt]={#,PfixManyTotLD[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl;
rt2[rr,dt]=Join[Reverse[rt2[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2[rr,dt],156]];
{ListIntegrate[rt2[rr,dt]],Fit[Log[Take[rt2[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-1)) (with LD)

rr=0.1;dt=0;
rt2[rr,dt]={#,PfixManyTotLD[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6),Plot->True][[2]]}&/@xl;
rt2[rr,dt]=Join[Reverse[rt2[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2[rr,dt],1]]

LogLogListPlot[Drop[rt2[rr,dt],156]];
{ListIntegrate[rt2[rr,dt]],Fit[Log[Take[rt2[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-2)) (with LD)

rr=0.01;dt=0;
rt2[rr,dt]={#,PfixManyTotLD[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl2;
rt2[rr,dt]=Join[Reverse[rt2[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2[rr,dt],156]];
{ListIntegrate[rt2[rr,dt]],Fit[Log[Take[rt2[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-3)) (with LD)

rr=0.001;dt=0;
rt2[rr,dt]={#,PfixManyTotLD[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6),Plot->True][[2]]}&/@xl2;
rt2[rr,dt]=Join[Reverse[rt2[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2[rr,dt],156]];
{ListIntegrate[rt2[rr,dt]],Fit[Log[Take[rt2[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-4)) (with LD)

rr=0.0001;dt=0;
rt2[rr,dt]={#,PfixManyTotLD[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl3;
rt2[rr,dt]=Join[Reverse[rt2[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2[rr,dt],156]];
{ListIntegrate[rt2[rr,dt]],Fit[Log[Take[rt2[rr,dt],-20]],{1,lr},lr]}

ρ=1 (LE)

rr=1;dt=0;
rt2LE[rr,dt]={#,PfixManyTot[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl;
rt2LE[rr,dt]=Join[Reverse[rt2LE[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2LE[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2LE[rr,dt],156]];
{ListIntegrate[rt2LE[rr,dt]],Fit[Log[Take[rt2LE[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-1)) (LE)

rr=0.1;dt=0;
rt2LE[rr,dt]={#,PfixManyTot[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl;
rt2LE[rr,dt]=Join[Reverse[rt2LE[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2LE[rr,dt],1]]

LogLogListPlot[Drop[rt2LE[rr,dt],156]];
{ListIntegrate[rt2LE[rr,dt]],Fit[Log[Take[rt2LE[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-2)) (LE)

rr=0.01;dt=0;
rt2LE[rr,dt]={#,PfixManyTot[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl2;
rt2LE[rr,dt]=Join[Reverse[rt2LE[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2LE[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2LE[rr,dt],156]];
{ListIntegrate[rt2LE[rr,dt]],Fit[Log[Take[rt2LE[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-3)) (LE)

rr=0.001;dt=0;
rt2LE[rr,dt]={#,PfixManyTot[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6),Plot->True][[2]]}&/@xl2;
rt2LE[rr,dt]=Join[Reverse[rt2LE[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2LE[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2LE[rr,dt],156]];
{ListIntegrate[rt2LE[rr,dt]],Fit[Log[Take[rt2LE[rr,dt],-20]],{1,lr},lr]}

ρ=(10^(-4)) (LE)

rr=0.0001;dt=0;
rt2LE[rr,dt]={#,PfixManyTot[{{1,1},{-rr(1-#),rr #},{-10-(dt/2),-10+(dt/2)}},{-20,30},(10^6)][[2]]}&/@xl3;
rt2LE[rr,dt]=Join[Reverse[rt2LE[rr,dt]/.{xx_,y_}:>{1-xx,y}],Drop[rt2LE[rr,dt],1]];
Print["Graph:"];LogLogListPlot[Drop[rt2LE[rr,dt],156]];
{ListIntegrate[rt2LE[rr,dt]],Fit[Log[Take[rt2LE[rr,dt],-20]],{1,lr},lr]}

Plotting the results

GraphicsRow[{ListLogLogPlot[Append[o2avePlotTable,{#[[1]],2#[[2]]}&/@ tblOmega1[[;;-2]]],Joined->True,PlotStyle->(Append[#,Thick]&/@{{},{Dashed},{Dotted}}),PlotLegend->{"N = (10^5)","N = ∞","Separated\n sweeps"},LegendShadow->False,LegendSize->{.4,.5},LegendPosition->{-.7,-.35},Evaluate[goodlabel["Scaled map distance, r/s","Reduction in fixation probability, Ω",14]]],ListLogLinearPlot[{{{1,4.799},{0.1,4.449},{0.01,4.348},{0.001,4.222},{0.0001,4.160}},{{1,4.221},{0.1,4.305},{0.01,4.307},{0.001,4.193},{0.0001,4.160}},{{1,4*1.05},{(10^(-4)),4*1.05}}},Joined->True,PlotStyle->(Append[#,Thick]&/@{{},{Dashed},{Dotted}}),Ticks->{Automatic,{0,2,4}},PlotRange->{{0.00008,1.5},{0,5}},PlotLegend->{"N = (10^6)","N = ∞","Separated\n sweeps"},LegendShadow->False,LegendSize->{.4,.5},LegendPosition->{0.5,-.35},Evaluate[goodlabel["Scaled map distance, r/s","Scaled net reduction in\nfixation probability, (1/s)∫Ω\[DifferentialD]r",14]]]}]

Figure S6: Interference coefficient (Subscript[Z, s/S]).

Set the beginning and end of the scaled time window we’ll consider:

T0 = -15; T1 = 15;

For s=S:

This shows the contribution of each order-of-magnitude of the scaled recombination rate ρ to Z:

xx=Table[
tt=Table[{ρ,PfixTot[{1,ρ},{T0,T1}]},{ρ,(10^a),(10^(a+1)),(1/3) (10^a)}];
int=Interpolation[tt];{(10^a),(10^(a+1)),NIntegrate[int[ρ],{ρ,(10^a),(10^(a+1))}]}//N,{a,-5,2}];
xx//TableForm

The total interference coefficient Z is the sum of the last column:

Total[Last/@xx]

For different s, S:

For each value of s/S, we’ll calculate the interference caused at a range of recombination rates, then interpolate between them and integrate over recombination rate to get the total interference coefficient (Subscript[Z, s/S]). We’ll need to rescale the time window with s to make sure it includes the full sweep.

For s=S/100:

tthundredth=Table[{a,PfixTot[{1/100,(10^a)},{100T0,100T1}]},{a,-5,2,0.2}];
inthundredth=Interpolation[tthundredth];
NIntegrate[inthundredth[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=S/30:

ttthirtieth=Table[{a,PfixTot[{1/30,(10^a)},{30T0,30T1}]},{a,-5,2,0.2}];
intthirtieth=Interpolation[ttthirtieth];
NIntegrate[intthirtieth[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=S/10:

tttenth=Table[{a,PfixTot[{1/10,(10^a)},{10T0,10T1}]},{a,-5,2,0.2}];
inttenth=Interpolation[tttenth];
NIntegrate[inttenth[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=S/3:

ttthird=Table[{a,PfixTot[{1/3,(10^a)},{3T0,3T1}]},{a,-5,2,0.2}];
intthird=Interpolation[ttthird];
NIntegrate[intthird[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=2S:

tt2=Table[{a,PfixTot[{2,(10^a)},{T0,T1}]},{a,-5,2,0.2}];
int2=Interpolation[tt2];
NIntegrate[int2[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=10S:

tt10=Table[{a,PfixTot[{10,(10^a)},{T0,T1}]},{a,-5,2,0.2}];
int10=Interpolation[tt10];
NIntegrate[int10[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=30S:

tt30=Table[{a,PfixTot[{30,(10^a)},{T0,T1}]},{a,-5,2,0.2}];
int30=Interpolation[tt30];
NIntegrate[int30[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

For s=100S:

tt100=Table[{a,PfixTot[{100,(10^a)},{T0,T1}]},{a,-5,2,0.2}];
int100=Interpolation[tt100];
NIntegrate[int100[Log[10,ρ]],{ρ,(10^(-5)),(10^2)}]

Putting these results together:

Z as a function of θ=s/S:

zTable={{100,0.005000550441371094`},{30,0.025638594593491763`},{10,0.09100551972046374`},{2,0.49714218623056045`},{1,1.0483514628186865`},{1/3,2.814868940224828`},{.1,6.572123454867627`},{1/30,14.166703589349709`},{.01,34.579097178632864`}};

Try to match the small-θ behavior from Barton 1994:

N[Exp[(π^2)/(6*1.0483514628186865`)]-1]

zTheta[θ_]:=(π^2)/(6θ Log[a+1/θ])/.{a->3.802167432879058`};

Plot the result, along with the numerical calculations, the small-θ result from Barton 1994, and the simple approximation (Subscript[Z, θ])≈(Subscript[Z, 1])/θ:

Show[LogLogPlot[{(π^2)/(6θ Log[1/θ]),1.0483514628186865`/θ,zTheta[θ]},{θ,(10^(-2.3)),50},PlotStyle->{Automatic,Automatic,Black},PlotRange->{Automatic,{.007,100}}],ListLogLogPlot[zTable,PlotStyle->{Black},PlotMarkers->{Automatic,10}],Evaluate[goodlabel["Ratio of selective advantages, s/S","Interference coefficient, (Subscript[Z, s/S])",16]]]