Definitions

StartPop::ussage"StartPop[ngenes_,nn_,nd_,mut_] Sets up a population with ngenes loci, for nn individuals, across nd demes: array is demes
(individuals(loci)). The population is up to mutation mut fixed to 0 or 1 for each of the gene; StartPop[ngenes_,nn_,nd_,mut_,width_,δ_].
 Sets up an adapted population with ngenes loci, for nn individuals, across nd demes. For clines, 1 is picked with prob. p, 0 woth prob. q";
StartPop[ngenes_,nn_,nd_]:=Module[{mut=0.002,rrr},StartPop[ngenes,nn,nd,mut_]];StartPop[ngenes_,nn_,nd_,mut_]:=Module[{rrr},rrr=RandomChoice[{1/2,1/2}->{0,1},ngenes];Mutate[ConstantArray[rrr,{nd,nn}],mut,nd]];
StartPop[ngenes_,nn_,nd_,mut_,width_,δ_]:=Module[{pList,x,x0},pList=Table[Table[1/(1+Exp[-4/width( x-x0)]),{x,-(nd-1)/2,(nd-1)/2}],{x0,Max[{-(nd-1)/2,-(δ /2)(ngenes-1)}],Min[{(nd-1)/2,δ/2 ( ngenes-1)}],Min[{δ,(nd-1)/Max[{1,ngenes-1}]}]}]//Chop;Table[Table[RandomChoice[{#,1-#}-> {1,0}]&/@(Transpose[pList][[i]]),{j,nn}],{i,nd}]];StartPop[ngenes_,propAdapt_,nn_,nd_,mut_,width_,δ_]:=Module[{i,pop1,pop2},pop1=StartPop[Ceiling[ngenes propAdapt],nn,nd,mut,width,δ];pop2=StartPop[ngenes-Ceiling[ngenes propAdapt],nn,nd,mut];Table[MapThread[Join[#1,#2]&,{pop1[[i]],pop2[[i]]}],{i,nd}]]

StartPopdX[ngenes_,nn_,nd_,mut_,δx_]:=Module[{rrr},rrr=Join[ConstantArray[0,Floor[ngenes/2]],ConstantArray[1,Ceiling[ngenes/2]]];
Mutate[ConstantArray[rrr,{Floor[nd/δx],nn}],mut]];

StartPopdX[ngenes_,nn_,nd_,mut_,width_,δ_,δx_]:=Module[{pList,x,x0},
pList=Table[Table[1/(1+Exp[-4/width( x-x0)]),{x,-(nd-δx)/2,(nd-δx)/2,δx}],{x0,- ((δ (ngenes -δx))/2), ((δ (ngenes -δx))/2),δ}]//Chop;
Table[Table[RandomChoice[{#,1-#}-> {1,0}]&/@(Transpose[pList][[i]]),{j,nn}],{i,Floor[nd/δx]}]];

StartPopdX[ngenes_,propAdapt_,nn_,nd_,mut_,width_,δ_,δx_]:=Module[{i,pop1,pop2},
pop2=Table[Table[1/(1+Exp[-4/width( x-x0)]),{x,-(nd-δx)/2,(nd-δx)/2,δx}],{x0,-propAdapt((δ (ngenes -δx))/2),propAdapt((δ (ngenes -δx))/2),δ}]//Chop;
pop1=Table[Table[RandomChoice[{#,1-#}-> {1,0}]&/@(Transpose[pop2][[i]]),{j,nn}],{i,Floor[nd/δx]}];
If[ngenes-Ceiling[ngenes propAdapt]>0,pop2=StartPopdX[ngenes-Ceiling[ngenes propAdapt],nn,nd,mut,δx];
Table[MapThread[Join[#1,#2]&,{pop1[[i]],pop2[[i]]}],{i,Floor[nd/δx]}],pop1]]

StartPopdXAlphas[ngenes_,nn_,nd_,mut_,widthList_,δList_,b_,δx_]:=Module[{i,pList,Accδ=Accumulate[δList]},
pList=Table[Table[1/(1+Exp[-4/widthList[[i]]( x - ((Accδ[[-1]]-δx)/2)+ Accδ[[i]])]),{x,-( nd-δx)/2,( nd-δx)/2,δx}],{i,1,ngenes}]//Chop;
Table[Table[RandomChoice[{#,1-#}-> {1,0}]&/@(Transpose[pList][[i]]),{j,nn}],{i,Floor[nd/δx]}]];

StartPopdXAlphas[ngenes_,propAdapt_,nn_,nd_,mut_,widthList_,δList_,b_,δx_]:=Module[{i,pop1,pop2,Accδ=Accumulate[δList]},
pop2=Table[Table[1/(1+Exp[-4/widthList[[i]]( x-((Accδ[[Ceiling[ngenes propAdapt]]]-δx)/2)+Accδ[[i]])]),{x,-( nd-δx)/2,( nd-δx)/2,δx}],{i,1,Ceiling[ngenes propAdapt]}]//Chop;
pop1=Table[Table[RandomChoice[{#,1-#}-> {1,0}]&/@(Transpose[pop2][[i]]),{j,nn}],{i,Floor[nd/δx]}];
If[ngenes-Ceiling[ngenes propAdapt]>0,pop2=StartPopdX[ngenes-Ceiling[ngenes propAdapt],nn,nd,mut,δx];
Table[MapThread[Join[#1,#2]&,{pop1[[i]],pop2[[i]]}],{i,Floor[nd/δx]}],pop1]]

Mutate[pop_,mut_,ng_]:=Module[{nd=Length[pop],nnList=Length[#]&/@pop,NR,mutpos,i,AccnnList,AllGenes=Length[pop//Flatten],upTo,InDeme},
AccnnList=Accumulate[nnList];NR=RandomSample[Range[AllGenes],Random[BinomialDistribution[AllGenes,mut]]];
mutpos=Flatten[Table[upTo=Select[AccnnList,#<Ceiling[NR[[i]] /(ng)]&];InDeme=(NR[[i]]-Plus@@(upTo/.{}-> {{}})[[-1]] ng);mutpos={{Length[upTo]+1,Quotient[InDeme-1,ng]+1,Mod[InDeme,ng]/.(0->ng)}},{i,1,Length[NR]}],1];
i=0;Nest[(i=i+1;ReplacePart[#,mutpos[[i]]->Abs[1-Extract[#,mutpos[[i]]]]])&,pop,Length[mutpos]]]

Mutate[pop_,mut_]:=Module[{nd=Length[pop],nnList=Length[#]&/@pop,NR,mutpos,i,AccnnList,AllGenes=Length[pop//Flatten],upTo,InDeme,ng},i=Flatten[Position[nnList,Max[nnList]]][[1]];
ng=Length[pop[[i,1]]];
AccnnList=Accumulate[nnList];NR=RandomSample[Range[AllGenes],Random[BinomialDistribution[AllGenes,mut]]];
mutpos=Flatten[Table[upTo=Select[AccnnList,#<Ceiling[NR[[i]] /(ng)]&];InDeme=(NR[[i]]-Plus@@(upTo/.{}-> {{}})[[-1]] ng);mutpos={{Length[upTo]+1,Quotient[InDeme-1,ng]+1,Mod[InDeme,ng]/.(0->ng)}},{i,1,Length[NR]}],1];
i=0;Nest[(i=i+1;ReplacePart[#,mutpos[[i]]->Abs[1-Extract[#,mutpos[[i]]]]])&,pop,Length[mutpos]]]

MutateOld::ussage"SLOW";
MutateOld[pop_,mut_]:=Module[{nd=Length[pop]},Table[ Map[RandomChoice[{1-mut,mut}-> {#,1-#}]&,pop[[i]],{2}],{i,nd}]];MutateOld[pop_,mut_,nd_]:=Module[{},Table[ Map[RandomChoice[{1-mut,mut}-> {#,1-#}]&,pop[[i]],{2}],{i,nd}]];

αList[α_,ngenes_]:=RandomReal[ExponentialDistribution[1/α],ngenes];

αList[ngenes_]:=RandomReal[{(10^(-3)),.1},ngenes];

θ::ussage"The linear gradient is normalised so that the intermediate phenotype is best adapted at the centre of the range! α";
θ[b_,nd_,ngenes_]:=Table[ngenes/2+b x,{x,-(nd-1)/2,(nd-1)/2,1}];
θ[b_,nd_,ngenes_,δx_,α_]:=Table[α ngenes/2+b x,{x,-(nd-δx)/2,(nd-δx)/2,δx}];
θAlphas[b_,nd_,ngenes_,δx_,αα_]:=Table[((Plus@@αα)/2)+b x,{x,-(nd-δx)/2,(nd-δx)/2,δx}];
θSteep[b_,nd_,ngenes_,δx_,α_]:=Module[{k=b/2},Table[α ngenes/2 + Exp[k x]-Exp[-k x],{x,-(nd-δx)/2,(nd-δx)/2,δx}]];

MigrateStSt[pop_]:=Module[{rr,rrL,rrR,poploc,popL,popR,nd=Length[pop]},rr=RandomChoice[{1/4,1/2,1/4}-> {-1,0,1},Length[#]]&/@pop;rr=ReplacePart[ReplacePart[rr,1->(If[#==-1,0,#]&/@rr[[1]])],-1-> (If[#==1,0,#]&/@rr[[-1]])];popL=Append[Drop[pop,1],pop[[-1]]];popR=Prepend[Drop[pop,-1],pop[[1]]];rrL=Append[Drop[rr,1],0rr[[-1]]];rrR=Prepend[Drop[rr,-1],0rr[[1]]];poploc=Table[MapThread[If[#1==0,#2,0]&,{rr[[i]],pop[[i]]}],{i,nd}];popL=Table[MapThread[If[#1==-1,#2,0]&,{rrL[[i]],popL[[i]]}],{i,nd}];popR=Table[MapThread[If[#1==1,#2,0]&,{rrR[[i]],popR[[i]]}],{i,nd}];Cases[#,Except[0]]&/@(Table[Join[poploc[[i]],popL[[i]],popR[[i]]],{i,nd}])]

MigrateStSt[pop_,m_]:=Module[{rr,rrL,rrR,poploc,popL,popR,nd=Length[pop]},rr=RandomChoice[{m/2,(1-m),m/2}-> {-1,0,1},Length[#]]&/@pop;rr=ReplacePart[ReplacePart[rr,1->(If[#==-1,0,#]&/@rr[[1]])],-1-> (If[#==1,0,#]&/@rr[[-1]])];popL=Append[Drop[pop,1],pop[[-1]]];popR=Prepend[Drop[pop,-1],pop[[1]]];rrL=Append[Drop[rr,1],0rr[[-1]]];rrR=Prepend[Drop[rr,-1],0rr[[1]]];poploc=Table[MapThread[If[#1==0,#2,0]&,{rr[[i]],pop[[i]]}],{i,nd}];popL=Table[MapThread[If[#1==-1,#2,0]&,{rrL[[i]],popL[[i]]}],{i,nd}];popR=Table[MapThread[If[#1==1,#2,0]&,{rrR[[i]],popR[[i]]}],{i,nd}];Cases[#,Except[0]]&/@(Table[Join[poploc[[i]],popL[[i]],popR[[i]]],{i,nd}])]

Migrate[pop_,gg_]:=Module[{i,j,ij,nd,pp,displ,nnList=Length[#]&/@pop},
i=1;j=1;ij=1;nd=Length[pop];pp=ConstantArray[{},nd];
displ=RandomChoice[gg-> Range[-((Length[gg]-1)/2),(Length[gg]-1)/2],Plus@@nnList];
For[ij=1,ij≤Length[displ],ij=ij+1,If[((j==nnList[[i]]+1)||(nnList[[i]]==0)),j=1;i=i+1;ij=ij-1,pp=Insert[pp,pop[[i,j]],{Min[{nd,Max[{1,i+displ[[ij]]}]}],1}];j=j+1]];pp]

gaussianList::usage="gaussianList[σ,ϵ,k] approximates a Gaussian function with s.d. σ, and grid spacing ϵ; truncates at k sd  (3sd by default), and adjusts so that the variance is given correctly.";

gaussianList[σ_,ϵ_]:=gaussianList[σ,ϵ,3];
gaussianList[σ_,ϵ_,k_]:=Module[{g,s0,s2,s4,x,kk,n},
kk=Nearest[Table[n ϵ/σ,{n,1,k Ceiling[σ/ϵ]+1}],k][[1]];x=Range[-kk σ,kk σ,ϵ];g=(PDF[NormalDistribution[0,σ],#]//N)&/@x;
s0=Plus@@g;s2=g.x^2;s4=g.x^4;
Select[g (s2 (σ^2+x^2)-s4-σ^2 x^2 s0)/(s2^2-s0 s4),#>0&]]//Chop//N;

SplitSexes::ussage"within each deme assigns a splitting index to get half offspring to be female, half to be male. Forces equal sex ratio in each deme: the only randomness is +-1";
SplitSexes[pop_]:=Module[{i,nnList=Length[#]&/@pop,nd=Length[pop]},Table[Quotient[nnList[[i]],2]+Mod[nnList[[i]],2]Random[Integer,{0,1}],{i,nd}]]

Options[SelectRecombine]={Regulation->∞};

SelectMutateRecombine::ussage"SelectRecombine Migrates (pop,{b,Vs,rstar||\!\(\*SubscriptBox[\(r\), \(m\)]\),K},ngenes,Regulation-> ∞ is Logarithmic. Plant model. 
Asigns fitnesses, calculates the expected number of ofspring \!\(\*SubscriptBox[\(N\), \(\(i\)\(\\\ \)\)]\)(Poisson dist.) for each individual, 
asigns male according to their fitness (including *self*) and recombines (Recombine: with free recombination). 
\!\(\*SubscriptBox[\(r\), \(\(m\)\(\\\ \)\)]\)in the logarithmic model is \!\(\*SuperscriptBox[\(r\), \(*\)]\)";
SelectMutateRecombine[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{θlist,i,rm=pars[[3]],Vs=pars[[2]],b=pars[[1]],K=pars[[4]],α=pars[[8]],nd=Length[pop],rr,zz,reg,Nfem,Ndeme,popfem,popmale},
reg=Regulation/.{opts}/.Options[SelectRecombine];θlist=θ[b,nd,ngenes,δx,α];Ndeme=Length[#]&/@pop;zz=α Plus@@#&/@#&/@pop;
If[reg==∞,rr=Exp[(-rm Log[Ndeme/K]-(zz-θlist)^2/(2 Vs))],rr=Exp[rm(1-Ndeme/K)-(zz-θlist)^2/(2 Vs)]];
Nfem=Map[RIP,rr,{2}];Ndeme=Plus@@#&/@Nfem;popmale=MapThread[If[#1!={}&&#3!=0,RandomChoice[#1-> #2,#3]]&,{rr,pop,Ndeme}];
popfem=Table[Flatten[MapThread[ConstantArray[#1,#2]&,{pop[[i]],Nfem[[i]]}],1],{i,Floor[nd /δx]}];
MapThread[Recombine[#1,#2]&,{Mutate[popfem,pars[[5]]],Mutate[popmale,pars[[5]],ngenes]}]]

SelectMutateRecombineKList::ussage"SelectRecombine Migrates (pop,{b,Vs,rstar||\!\(\*SubscriptBox[\(r\), \(m\)]\),K},ngenes,Regulation-> ∞ is Logarithmic. Plant model. 
Asigns fitnesses, calculates the expected number of ofspring \!\(\*SubscriptBox[\(N\), \(\(i\)\(\\\ \)\)]\)(Poisson dist.) for each individual, 
asigns male according to their fitness (including *self*) and recombines (Recombine: with free recombination). 
\!\(\*SubscriptBox[\(r\), \(\(m\)\(\\\ \)\)]\)in the logarithmic model is \!\(\*SuperscriptBox[\(r\), \(*\)]\)";
SelectMutateRecombineKList[pop_,pars_,KList_,ngenes_,δx_,opts___Rule]:=Module[{θlist,i,rm=pars[[3]],Vs=pars[[2]],b=pars[[1]],K=pars[[4]],α=pars[[8]],nd=Length[pop],rr,zz,reg,Nfem,Ndeme,popfem,popmale},
reg=Regulation/.{opts}/.Options[SelectRecombine];θlist=θ[b,nd,ngenes,δx,α];Ndeme=Length[#]&/@pop;zz=α Plus@@#&/@#&/@pop;
If[reg==∞,rr=Exp[(-rm Log[Ndeme/KList]-(zz-θlist)^2/(2 Vs))],rr=Exp[rm(1-Ndeme/KList)-(zz-θlist)^2/(2 Vs)]];
Nfem=Map[RIP,rr,{2}];Ndeme=Plus@@#&/@Nfem;popmale=MapThread[If[#1!={}&&#3!=0,RandomChoice[#1-> #2,#3]]&,{rr,pop,Ndeme}];
popfem=Table[Flatten[MapThread[ConstantArray[#1,#2]&,{pop[[i]],Nfem[[i]]}],1],{i,Floor[nd /δx]}];
MapThread[Recombine[#1,#2]&,{Mutate[popfem,pars[[5]]],Mutate[popmale,pars[[5]],ngenes]}]]

SelectMutateRecombineSteep::ussage"SelectRecombine Migrates (pop,{b,Vs,rstar||\!\(\*SubscriptBox[\(r\), \(m\)]\),K},ngenes,Regulation-> ∞ is Logarithmic. Plant model. 
Asigns fitnesses, calculates the expected number of ofspring \!\(\*SubscriptBox[\(N\), \(\(i\)\(\\\ \)\)]\)(Poisson dist.) for each individual, 
asigns male according to their fitness (including *self*) and recombines (Recombine: with free recombination). 
\!\(\*SubscriptBox[\(r\), \(\(m\)\(\\\ \)\)]\)in the logarithmic model is \!\(\*SuperscriptBox[\(r\), \(*\)]\)";
SelectMutateRecombineSteep[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{θlist,i,rm=pars[[3]],Vs=pars[[2]],b=pars[[1]],K=pars[[4]],α=pars[[8]],nd=Length[pop],rr,zz,reg,Nfem,Ndeme,popfem,popmale},
reg=Regulation/.{opts}/.Options[SelectRecombine];θlist=θSteep[b,nd,ngenes,δx,α];Ndeme=Length[#]&/@pop;zz=α Plus@@#&/@#&/@pop;
If[reg==∞,rr=Exp[(-rm Log[Ndeme/K]-(zz-θlist)^2/(2 Vs))],rr=Exp[rm(1-Ndeme/K)-(zz-θlist)^2/(2 Vs)]];
Nfem=Map[RIP,rr,{2}];Ndeme=Plus@@#&/@Nfem;popmale=MapThread[If[#1!={}&&#3!=0,RandomChoice[#1-> #2,#3]]&,{rr,pop,Ndeme}];
popfem=Table[Flatten[MapThread[ConstantArray[#1,#2]&,{pop[[i]],Nfem[[i]]}],1],{i,Floor[nd /δx]}];
MapThread[Recombine[#1,#2]&,{Mutate[popfem,pars[[5]],ngenes],Mutate[popmale,pars[[5]],ngenes]}]]

SelectMutateRecombineAlphas::ussage"SelectRecombine Migrates (pop,{b,Vs,rstar||\!\(\*SubscriptBox[\(r\), \(m\)]\),K},ngenes,Regulation-> ∞ is Logarithmic. Plant model. 
Asigns fitnesses, calculates the expected number of ofspring \!\(\*SubscriptBox[\(N\), \(\(i\)\(\\\ \)\)]\)(Poisson dist.) for each individual, 
asigns male according to their fitness (including *self*) and recombines (Recombine: with free recombination). 
\!\(\*SubscriptBox[\(r\), \(\(m\)\(\\\ \)\)]\)in the logarithmic model is \!\(\*SuperscriptBox[\(r\), \(*\)]\)";
SelectMutateRecombineAlphas[pop_,pars_,αα_,ngenes_,δx_,opts___Rule]:=Module[{θlist,i,rm=pars[[3]],Vs=pars[[2]],b=pars[[1]],K=pars[[4]],nd=Length[pop],rr,zz,reg,Nfem,Ndeme,popfem,popmale},
reg=Regulation/.{opts}/.Options[SelectRecombine];θlist=θAlphas[b,nd,ngenes,δx,αα];Ndeme=Length[#]&/@pop;zz=(Plus@@(αα#)&/@#&/@pop);
If[reg==∞,rr=Exp[(-rm Log[Ndeme/K]-(zz-θlist)^2/(2 Vs))],rr=Exp[rm(1-Ndeme/K)-(zz-θlist)^2/(2 Vs)]];
Nfem=Map[RIP,rr,{2}];Ndeme=Plus@@#&/@Nfem;popmale=MapThread[If[#1!={}&&#3!=0,RandomChoice[#1-> #2,#3]]&,{rr,pop,Ndeme}];
popfem=Table[Flatten[MapThread[ConstantArray[#1,#2]&,{pop[[i]],Nfem[[i]]}],1],{i,Floor[nd /δx]}];
MapThread[Recombine[#1,#2]&,{Mutate[popfem,pars[[5]],ngenes],Mutate[popmale,pars[[5]],ngenes]}]]

SelectMutateRecombineSteepAlpha::ussage"SelectRecombine Migrates (pop,{b,Vs,rstar||\!\(\*SubscriptBox[\(r\), \(m\)]\),K},ngenes,Regulation-> ∞ is Logarithmic. Plant model. 
Asigns fitnesses, calculates the expected number of ofspring \!\(\*SubscriptBox[\(N\), \(\(i\)\(\\\ \)\)]\)(Poisson dist.) for each individual, 
asigns male according to their fitness (including *self*) and recombines (Recombine: with free recombination). 
\!\(\*SubscriptBox[\(r\), \(\(m\)\(\\\ \)\)]\)in the logarithmic model is \!\(\*SuperscriptBox[\(r\), \(*\)]\)";
SelectMutateRecombineSteepAlpha[pop_,pars_,αα_,ngenes_,δx_,opts___Rule]:=Module[{θlist,i,rm=pars[[3]],Vs=pars[[2]],b=pars[[1]],K=pars[[4]],α=Mean[αα],nd=Length[pop],rr,zz,reg,Nfem,Ndeme,popfem,popmale},
reg=Regulation/.{opts}/.Options[SelectRecombine];θlist=θSteep[b,nd,ngenes,δx,α];Ndeme=Length[#]&/@pop;zz=(Plus@@(αα#)&/@#&/@pop);
If[reg==∞,rr=Exp[(-rm Log[Ndeme/K]-(zz-θlist)^2/(2 Vs))],rr=Exp[rm(1-Ndeme/K)-(zz-θlist)^2/(2 Vs)]];
Nfem=Map[RIP,rr,{2}];Ndeme=Plus@@#&/@Nfem;popmale=MapThread[If[#1!={}&&#3!=0,RandomChoice[#1-> #2,#3]]&,{rr,pop,Ndeme}];
popfem=Table[Flatten[MapThread[ConstantArray[#1,#2]&,{pop[[i]],Nfem[[i]]}],1],{i,Floor[nd /δx]}];
MapThread[Recombine[#1,#2]&,{Mutate[popfem,pars[[5]],ngenes],Mutate[popmale,pars[[5]],ngenes]}]]

RIP[r_]:=If[(r//N//Chop)<=0,0,RandomInteger[PoissonDistribution[r]]];

Recombine::ussage"Recombines elements of the list with r=1/2 - takes two haploid sets";
Recombine[popfemdeme_,popmaledeme_]:=Module[{j,reclist,n=Length[popfemdeme],ngenes},ngenes=If[n==0,0,Length[popfemdeme[[1]]]];
reclist=Table[RandomChoice[{1,0},ngenes],{j,n}];popfemdeme*reclist+(1-reclist)popmaledeme]

SelectRecombineMigrate[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectRecombine[Mutate[Migrate[pop,gg],pars[[5]]],pars,ngenes,δx,opts]];

SelectRecombineMigrate[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectRecombine[Mutate[Migrate[pop,gg],pars[[5]]],pars,ngenes,δx,opts]];

MigrateSelectMutateRecombine[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectMutateRecombine[Migrate[pop,gg],pars,ngenes,δx,opts]];

MigrateSelectMutateRecombineAlphas[pop_,pars_,αα_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectMutateRecombineAlphas[Migrate[pop,gg],pars,αα,ngenes,δx,opts]];

MigrateSelectMutateRecombineSteep[pop_,pars_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectMutateRecombineSteep[Migrate[pop,gg],pars,ngenes,δx,opts]];

MigrateSelectMutateRecombineSteepAlpha[pop_,pars_,αα_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectMutateRecombineSteepAlpha[Migrate[pop,gg],pars,αα,ngenes,δx,opts]];

MigrateSelectMutateRecombineKList[pop_,pars_,KList_,ngenes_,δx_,opts___Rule]:=Module[{gg=gaussianList[pars[[6]],δx,pars[[7]]]},SelectMutateRecombineKList[Migrate[pop,gg],pars,KList,ngenes,δx,opts]];

Iterate[pop_,pars_,ngenes_,δx_,opts___Rule,T_]:=Nest[SelectRecombineMigrate[#,pars,ngenes,δx,opts]&,pop,T];

Iterate[pop_,pars_,ngenes_,δx_,opts___Rule,T_]:=Nest[MigrateSelectMutateRecombine[#,pars,ngenes,δx,opts]&,pop,T];

Iterate[pop_,pars_,ngenes_,δx_,opts___Rule,T_,dT_]:=NestList[Iterate[#,pars,ngenes,δx,opts,dT]&,pop,Quotient[T,dT]];

IterateKList[pop_,pars_,KList_,ngenes_,δx_,opts___Rule,T_]:=Nest[MigrateSelectMutateRecombineKList[#,pars,KList,ngenes,δx,opts]&,pop,T];

IterateKList[pop_,pars_,KList_,ngenes_,δx_,opts___Rule,T_,dT_]:=NestList[IterateKList[#,pars,KList,ngenes,δx,opts,dT]&,pop,Quotient[T,dT]];

IterateAlphas[pop_,pars_,αα_,ngenes_,δx_,opts___Rule,T_]:=Nest[MigrateSelectMutateRecombineAlphas[#,pars,αα,ngenes,δx,opts]&,pop,T];

IterateAlphas[pop_,pars_,αα_,ngenes_,δx_,opts___Rule,T_,dT_]:=NestList[IterateAlphas[#,pars,αα,ngenes,δx,opts,dT]&,pop,Quotient[T,dT]];

IterateSteep[pop_,pars_,ngenes_,δx_,opts___Rule,T_]:=Nest[MigrateSelectMutateRecombineSteep[#,pars,ngenes,δx,opts]&,pop,T];

IterateSteep[pop_,pars_,ngenes_,δx_,opts___Rule,T_,dT_]:=NestList[IterateSteep[#,pars,ngenes,δx,opts,dT]&,pop,Quotient[T,dT]];

IterateSteepAlpha[pop_,pars_,αα_,ngenes_,δx_,opts___Rule,T_]:=Nest[MigrateSelectMutateRecombineSteepAlpha[#,pars,αα,ngenes,δx,opts]&,pop,T];

IterateSteepAlpha[pop_,pars_,αα_,ngenes_,δx_,opts___Rule,T_,dT_]:=NestList[IterateSteepAlpha[#,pars,αα,ngenes,δx,opts,dT]&,pop,Quotient[T,dT]];

DarkGreen=Hue[{0.4,1,0.55}];

NiceBlue=Hue[{0.65,0.7,.7}];

DarkBlue=Hue[{0.65,0.7,.55}];

Initialization

This code generates a simulation run with linear gradient, uniform carrying capacity and constant allelic effects. The outcome  is the variable "popnew". The rest of the code processes a selection of summary statistics. The working code is above ("Definitions"). It runs for a short time of T = 200 generations (saving every dT = 10 generations) with carrying capacity kk = 20. [Evaluation: Evalutate Initialization Cells].

Variations: Exponential distribution of allelic effects is obtained with αα=αList[α,ngenes]. For a steepening gradient in the optimum θSteep, the iterating function is IterateSteepAlpha.  The initialization for the Random set (Figure 2) is below in a closed cell.

run="Example";

k=2;h=1;δx=1;propAdapt=1/2;LLAll={};

"k" gives the standard deviations for the diffusive dispersal.

rstar=1;
σ=(Sqrt[1/2]);
b=0.1;
Vs=1;
kk=20;

h=1;α=(Sqrt[1/100]);T=200;dTi=1dT;dT=10;

LLAll={};

bList={b};

For[i=1,i≤1,i=i+1,b=bList[[i]];
rm =rstar- ((b σ)/(2 (h^2)(Sqrt[Vs])));wpq=4(Sqrt[(((σ^2)Vs)/(α^2))]);nd =Ceiling[10 4(Sqrt[(((σ^2)Vs)/(α^2))])];ngenes=Ceiling[nd b/α];nn=kk(1-((b σ)/(2(h^2)(Sqrt[Vs]) rm)));mut=(10^(-5));
LL={b,Vs,σ,kk,nn,rm,rstar,α,mut,ngenes,propAdapt,δx,nd,T,dT,wpq};αα=αList[α,ngenes];αα=ConstantArray[α,ngenes];widthList=4(Sqrt[(((σ^2)Vs)/((αα)^2))]);δList=αα/b;
pop=StartPopdXAlphas[ngenes,propAdapt,Max[{1, Ceiling[nn]}],nd,mut,widthList,δList,b,δx];
pop=IterateAlphas[pop,{b ,Vs  ,rm ,kk ,mut ,σ ,k,α},αα,Round[ngenes] ,δx ,Regulation->1,1];
popnew=IterateAlphas[pop,{b ,Vs  ,rm ,kk ,mut ,σ ,k,α},αα,Round[ngenes] ,δx ,Regulation->1,T,dT];nnList=Table[Length[#]&/@popnew[[i]],{i,1,Quotient[T,dT]+1}];
MeanVarN=({Mean[#],Variance[#]}&/@{Drop[nnList,1]}//N)[[1]];MedianOFMeanVarN=Median[Cases[#,Except[0.]]]&/@MeanVarN;
MeanFragm=Median[Cases[Table[Select[Length[#]&/@(Cases[#,Except[0]]&/@SplitBy[nnList[[i]],#==0&]),#>2&]//Length,{i,1,Quotient[T,dT]+1}],Except[0]]];
Alive=Length[Cases[Plus@@#&/@nnList,Except[0]]];TMax=Min[{Alive,Quotient[T,dT]+1}];TMin=Max[1,TMax-9];
range=(((Length[#]-Count[#,0]))/(Min[{nd,Ceiling[Plus@@ αα /b]}]))&/@nnList//N;rangetillfix=Select[range,#>0&];r2dT=rangetillfix[[2]];
If[Length[rangetillfix]≤6,slope=-1;PCI={-1,-1};meangrad=-1;MeanWpq=0;MeanVarZ=0;MeanvarLE=0;nnLast=0,rangetillfix=Select[Take[rangetillfix,{5,Length[rangetillfix]}],#<1.0&];If[Length[rangetillfix]>1,lm=LinearModelFit[Table[{i-1,rangetillfix[[i]]-r2dT},{i,1,Length[rangetillfix]}],x,x,ConfidenceLevel->.98];PCI=lm["ParameterConfidenceIntervals"][[2]];slope=D[Normal[lm],x],slope=1;PCI={1,1}];
If[Plus@@nnList[[-1]]==0,nnLast=0;ExpFAcrossGenes=0;meangrad=-1;MeanWpq=0;MeanVarZ=0;MeanvarLE=0;
MeanVZC=0;MeanVLEC=0;MeanFluctN=0;Fragm=0;
ρ=0,nnLast=Mean[Cases[nnList[[-1]],Except[0]]];ρ=((nnList[[-1]])/(Plus@@nnList[[-1]]));
pList=Map[If[#=={},{},Mean[#]]&,popnew[[-1]]];varLELast=Plus@@#&/@(If[#=={},{},((αα)^2)#]&/@((#(1-#)&/@pList)));
MeanvarLE=Plus@@(varLELast ρ);

pListList=Table[Map[If[#=={},{},Mean[#]]&,popnew[[i]]],{i,TMin,TMax}];
pNullNull = ConstantArray[0, ngenes];pListNull= pListList /. {} -> pNullNull;
pTrans100=Table[Take[Transpose[pListNull[[i]]],{Max[1,Round[((ngenes propAdapt)/2)]-50],Min[Round[ngenes propAdapt],Round[((ngenes propAdapt)/2)]+50]}],{i,1,TMax-TMin+1}];
MeanDispl=Round[Mean[Plus@@#&/@pTrans100[[-1]]]];
SolidRangeFragments=Table[Length[#]&/@(SplitBy[nnList[[i]],#≤4&]),{i,TMin,TMax}];DropZeros=#[[-1]]&/@Table[Plus@@#&/@SplitBy[SolidRangeFragments[[i]],#≤Max[SolidRangeFragments[[i]]]-1&],{i,1,TMax-TMin+1}];DropZeros=If[#==nd,0,#]&/@DropZeros;
DropFirstZeros=#[[1]]&/@Table[Plus@@#&/@SplitBy[SolidRangeFragments[[i]],#≤Max[SolidRangeFragments[[i]]]-1&],{i,1,TMax-TMin+1}];DropFirstZeros=If[#==nd,0,#]&/@DropFirstZeros;
AlignedTable=Table[MapThread[Join[ConstantArray[0,Round[Plus@@#1]+#2],Drop[Drop[#1,-#3],#2],Join[ConstantArray[1,#3+nd-Round[Plus@@#1]]]]&,{pTrans100[[i]],ConstantArray[DropFirstZeros[[i]],Length[pTrans100[[i]]]],ConstantArray[DropZeros[[i]],Length[pTrans100[[i]]]]}],{i,1,TMax-TMin+1}];
pAlignedList=Transpose[Drop[AlignedTable,1]];
FluctForAllGenes=Plus@@(Variance[Drop[#,1]]//N)&/@pAlignedList;

Δnn=Take[Drop[nnList,1]-Drop[nnList,-1],{Max[1,TMin-1],TMax-1}]//N;
MeanFluctN=Median[Cases[Variance[Δnn],Except[0.]]];
Fragm=Select[Length[#]&/@(Cases[#,Except[0]]&/@SplitBy[nnList[[-1]],#==0&]),#>2&]//Length;wList=4 Plus@@(#(1-#))&/@Transpose[pList /. {} -> pNullNull]//N;MeanWpq=(Mean[Select[Take[wList,{1,ngenes}],#>Mean[((Cases[Take[wList,{1,ngenes}],Except[0.]])/10)]&]])/.Mean[{}]-> 0;If[MeanWpq>0,
ExpCline=Table[(1/(1+Exp[-4((x-nd)/MeanWpq)])),{x,1,2nd}];
ExpFAcrossGenes=Median[FluctForAllGenes/Plus@@(ExpCline(1-ExpCline))],ExpFAcrossGenes=Null];

zzAllList=Plus@@(αα#)&/@#&/@(popnew[[-1]]);
varzzList=If[Length[#]>1,Variance[#],{}]&/@zzAllList//N;MeanVarZ=Plus@@(Cases[varzzList ρ,Except[{}]]);

varLEP=Cases[varLELast,Except[0.]]//N;MeanVLEC=If[Length[varLEP]>2,Mean[Take[varLEP,Sort[{3Ceiling[Length[varLEP]/8],Floor[(5/8)Length[varLEP]]}]]],Mean[varLEP]];varZP=Cases[varzzList,Except[0.|{}]]//N;MeanVZC=If[Length[varZP]>2,Mean[Take[varZP,Sort[{3Ceiling[Length[varZP]/8],Floor[(5/8)Length[varZP]]}]]],Mean[varZP]];
zzList=If[#=={},{},Mean[#]]&/@zzAllList//N;meangrad=Plus@@(Cases[Drop[Append[zzList,zzList[[-1]]]-Prepend[zzList,zzList[[1]]],-1]ρ,Except[{}]])]];
LL=Join[LL,{MeanWpq,MeanVarZ,MeanvarLE,MeanVZC,MeanVLEC,range[[-1]],ExpFAcrossGenes,Null,MeanFragm,Null,MeanFluctN,MedianOFMeanVarN[[1]],Fragm,nnLast//N,PCI[[1]],slope,PCI[[2]],meangrad}]//N;
LLAll=Append[LLAll,LL];
DumpSave["/bignicksata/jpolechova/Range/PopMSB/Pop_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",popnew];popLast=popnew[[-1]];
DumpSave["/clusterhome/jpolechova/Range/PopLastMSB/PopLast_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",popLast];
DumpSave["/clusterhome/jpolechova/Range/StatsMSB/LL_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",LL];
DumpSave["/clusterhome/jpolechova/Range/Alpha/Alpha_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",αα];
DumpSave["/clusterhome/jpolechova/Range/F/FSel_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",FluctForAllGenes];
DumpSave["/clusterhome/jpolechova/Range/Wpq/Width_"<>ToString[run]<>ToString["_"]<>ToString[i]<>".mx",wList]];

DumpSave["/clusterhome/jpolechova/Range/SummSMSB/LLAll_" <> ToString[run] <> ".mx", LLAll];

Exit[]

For Random runs, the following rutine was used to generate the paramters :

10 simulation runs with linear gradient and uniform carrying capacity, using a distribution of parameters.

seed=999;

run="Random"<>ToString[seed];

SeedRandom[seed];

For[i=1,i≤10,i=i+1,ngenes=5001;B=2.1;rm=2.1;σ=.001;mut=10^-9;While[ngenes>4000||B>1.6||B<0.01||rm>2||σ<0.5||mut<10^-8,rstar=Random[NormalDistribution[1,1/3]];b=Random[Real,{0.01,2}];σ=Random[ExponentialDistribution[Log[2](Sqrt[2])]];Vs=Random[ExponentialDistribution[1]];rm=rstar + ((b σ)/(2 (h^2)(Sqrt[Vs])));nn=Random[Integer,{4,100}];kk=nn/(1-((b σ)/(2(h^2)(Sqrt[Vs]) rm)));α=Random[ExponentialDistribution[20]];s=((α^2)/(2Vs));nd =Ceiling[10 4(Sqrt[(((σ^2)Vs)/(α^2))])];ngenes=Ceiling[nd b/α];B=((b σ)/(rstar(Sqrt[2Vs])));mut=(1/(nn ngenes nd ))];wpq=4(Sqrt[(((σ^2)Vs)/(α^2))]);αα=ConstantArray[α,ngenes];widthList=4(Sqrt[(((σ^2)Vs)/((αα)^2))]);δList=αα/b;
LL={b,Vs,σ,kk,nn,rm,rstar,α,mut,ngenes,propAdapt,δx,nd,T,dT,wpq};]

Charts from data

Loading data

The data can be loaded [path modification is necessary] or used directly. [Definitions need to be evaluated].

<<"Range/StatsMSB/LL_Example_1.mx";LL

<<"Range/Alpha/Alpha_Example_1.mx";

<<"/clusterextra2/jpolechova/Range/PopMSB/Pop_Example_1.mx";

T=LL[[14]];dT=LL[[15]];h=1;b=LL[[1]];σ=LL[[3]];Vs=LL[[2]];rm=LL[[6]];kk=LL[[4]];α=LL[[8]];ngenes=Round[LL[[10]]];nd=LL[[13]];nn=kk(1-((b σ)/(2(h^2)(Sqrt[Vs]) rm)));rstar=rm-((b σ (Sqrt[Vs ]))/(2Vs));δx=1;

Charts

Needs["ErrorBarPlots`"]

Vopt=b σ (Sqrt[Vs]);width=4(Sqrt[(((σ^2)Vs)/(α^2))]);s=((α^2)/(2Vs));

Timing[nnList=Table[Length[#]&/@popnew[[i]],{i,1,Quotient[T,dT]+1}];]

FullRange=T;

Show[Table[Show[ListPlot[Transpose[{Range[0,T,dT],(((Length[#]-Count[#,0])&/@nnList)/(Min[{nd,Ceiling[Plus@@ αα/b]}]))}],Joined-> True,PlotStyle->{Thickness[0.002],Black}],ListPlot[Transpose[{Range[0,T,dT],(((Length[#]-Count[#,0])&/@nnList)/(Min[{nd,Ceiling[Plus@@ αα /b]}]))}],Joined->False,PlotStyle-> {PointSize[0.007],Black}],BaseStyle->{FontSize->14,FontFamily->"Helvetica"},FrameLabel-> {"Time in generations","Relative range size"},Frame->{{True,False},{True,False}},AxesOrigin-> {0,0.1},PlotRange-> {0.4,0.7}],{j,1,10}]]

Alive=Length[Cases[Plus@@#&/@nnList,Except[0]]];If[Alive<Quotient[T,dT]+1,Print[" > generation of EXTINCTION" Alive dT]];Alive

pListList=Table[Map[If[#=={},{},Mean[#]]&,popnew[[i]]],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

varLEList=Table[Plus@@#&/@(If[#=={},{},((αα)^2)#]&/@((#(1-#)&/@pListList[[i]]))),{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

pNull = ConstantArray[0, ngenes];pNullNull = ConstantArray[Null, ngenes];  pListZero = pListList /. {} -> pNull;pListNull= pListList /. {} -> pNullNull;

i=1;wpqFirst = 4 Plus @@ (# (1 - #)) & /@ Transpose[pListZero[[i]]]// N;

i=-1;wpqLast = 4 Plus @@ (# (1 - #)) & /@ Transpose[pListZero[[i]]]// N;

wListList =Table[4 Plus @@ (# (1 - #)) & /@ Transpose[pListZero[[i]]], {i, 1, Min[{Alive, Quotient[T, dT] + 1}]}] // N;

Timing[zzAllList=Table[Plus@@(αα#)&/@#&/@(popnew[[i]]),{i,1,Quotient[T,dT]+1}]//N;]

zzList=Table[If[#=={},{},Mean[#]]&/@zzAllList[[i]],{i,1,Quotient[T,dT]+1}]//N;

zzdemeList=Table[Flatten[Transpose[#]&/@Table[{ConstantArray[j,Length[zzAllList[[i,j]]]],zzAllList[[i,j]]},{j,1,Floor[nd/δx]}],1],{i,1,Quotient[T,dT]+1}];

varzzList=Table[If[Length[#]>1,Variance[#],{}]&/@zzAllList[[i]],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];varzzList=varzzList/.{}-> Null;

xmin=0;xmax=nd;

bthr=.;{ThresholdGrad=bthr/.Solve[bthr==.15 nn(1-((bthr σ)/(2(h^2)(Sqrt[Vs]) rm))) (Sqrt[ s])(Sqrt[2 Vs])(rm - ((bthr σ)/(2 (h^2)(Sqrt[Vs]))))][[1]], ExtThrGrad=((2 rm (Sqrt[Vs]))/σ)}

((ThresholdGrad σ)/((Sqrt[2Vs])rstar))

{Thresholdnn=nnthr/.Solve[ThresholdGrad==.15 nnthr (Sqrt[ s])(Sqrt[2 Vs])(1- ((ThresholdGrad σ)/(2 (h^2)(Sqrt[Vs]))))][[1]]}

ListAnimate[Table[Show[ListPlot[θ[b,nd,ngenes,δx,α],Joined-> True,PlotStyle-> {Dashed,Black,Thickness[0.003]},
BaseStyle->{FontSize->20,FontFamily->"Helvetica"},ImageSize-> Scaled[.5]],ListPlot[zzdemeList[[i]],Joined-> False,PlotStyle->{Lighter[Blue,.5], PointSize[0.005]}],ListPlot[zzList[[i]]/.{}-> Null,Joined-> True,PlotStyle-> {Blue,Thickness[0.003]}],FrameLabel-> {"space","Optimum θ, Trait z, (OverBar[z])"},Frame->{{True,False},{True,False}},AxesOrigin-> {xmin,0},PlotRange-> {{xmin,xmax},{0,Plus@@αα+.9}}],{i,1,Quotient[T,dT]+1}]]

varzzList=Table[If[Length[#]>1,Variance[#],{}]&/@zzAllList[[i]],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];varzzList=varzzList/.{}-> Null;

{nd=Length[popnew[[1]]],LL[[13]]}

Timing[zzdemeList=Table[Flatten[Transpose[#]&/@Table[{ConstantArray[j,Length[zzAllList[[i,j]]]],zzAllList[[i,j]]},{j,1,Floor[nd/δx]}],1],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];]

pNull = ConstantArray[Null, ngenes]; pList = pList /. {} -> pNull;

nM=Max[Drop[Drop[#,-1],1]]&/@nnList;nMMax=Max[nM];{xmin,xmax}

i=1;alive=Cases[Flatten[Position[nnList[[i]],Except[Null]]],Except[0]];{xmin,xmax}

i=-1;

sh=14;

padding={{50,8},{42,10}};

LowArrowCoord={{30.5,26.5},{24.5,24.5}};LowArrow={Arrowheads[Small],Arrow[LowArrowCoord]};

HighArrowCoord={{83,36},{89.5,38}};HighArrow={Arrowheads[Small],Arrow[HighArrowCoord]};

Show[GraphicsGrid[{{Show[ListPlot[θ[b,nd,ngenes,δx,α],Joined-> True,PlotStyle-> {Dashed,Black,Thickness[0.005]},
FrameLabel-> {"Space","Optimum θ, Trait z, (OverBar[z])"},Frame->{{True,False},{True,False}},BaseStyle->{FontSize->14,FontFamily->"Helvetica"}],ListPlot[zzdemeList[[i]],Joined-> False,PlotStyle->{Lighter[Blue,.4], PointSize[0.01]}],ListPlot[zzList[[i]]/.{}-> Null,Joined-> False,PlotStyle->{Blue, PointSize[0.003]}],ListPlot[zzList[[i]]/.{}-> Null,Joined-> True,PlotStyle-> {Blue,Thickness[0.005]}],
ListPlot[zzdemeList[[1]],Joined-> False,PlotStyle->{Hue[.57,0.6,.9], PointSize[0.01]}],ListPlot[zzList[[1]]/.{}-> Null,Joined-> False,PlotStyle->{Hue[.6,0.9,.9], PointSize[0.003]}],ListPlot[zzList[[1]]/.{}-> Null,Joined-> True,PlotStyle-> {Hue[.6,0.9,.9],Thickness[0.005]}],
Graphics[Inset["A",ImageScaled[{0.185,0.9}],BaseStyle->{Bold,FontSize->14,FontFamily->"Helvetica"}]],
PlotRange->{{xmin,xmax}, {0,α ngenes+.9}},AxesOrigin-> {xmin,0},ImagePadding-> padding],
Show[ListPlot[nnList[[i]],PlotStyle-> {Black,PointSize[0.01]},Joined-> False,AxesOrigin-> {xmin,0},PlotRange->{{xmin,xmax},{0,1.5nn}},FrameLabel-> {"Space","Population size N"},Frame->{{True,False},{True,False}},BaseStyle->{FontSize->14,FontFamily->"Helvetica"}],ListPlot[nnList[[i]],PlotStyle->{Black,Thickness[0.003]},Joined-> True],Plot[nn,{x,0,nd},PlotStyle-> {Thickness[0.005],Black,Dashed}],Graphics[Inset["B",ImageScaled[{0.185,0.9}],BaseStyle->{Bold,FontSize->14,FontFamily->"Helvetica"}]],ImagePadding-> padding]},{Show[ListPlot[Take[Transpose[pListNull[[i]]],{1,ngenes}],PlotStyle->ConstantArray[{GrayLevel[0.6],Thickness[0.001]},Length[pListNull]],Joined-> True,PlotRange->{{xmin,xmax}, {-0.01,1.01}},AxesOrigin-> {xmin,0},PlotStyle-> PointSize[0.01],AxesOrigin-> {1,0},FrameLabel-> {"Space","Allele frequencies (Subscript[p, i])"},Frame->{{True,False},{True,False}},BaseStyle->{FontSize->14,FontFamily->"Helvetica"}],ListPlot[Take[Transpose[pListNull[[i]]],{Round[ngenes/4]+16,Round[ngenes/4]+16}],PlotStyle-> {Black,Thickness[0.003]},Joined-> True],ListPlot[Take[Transpose[pListNull[[i]]],{Round[ngenes/4]+20,Round[ngenes/4]+20}],PlotStyle-> {Black,Thickness[0.003]},Joined-> True],
ListPlot[Take[Transpose[pListNull[[i]]],{Round[ngenes/4],Round[ngenes/4]}],PlotStyle-> {Black,Thickness[0.003]},Joined-> True],Graphics[Inset["C",ImageScaled[{0.185,0.9}],BaseStyle->{Bold,FontSize->14,FontFamily->"Helvetica"}]],AxesOrigin-> {170,0},ImagePadding-> padding],Show[ListPlot[varzzList[[i]]/.{}-> Null,Joined->False,PlotStyle-> {Blue,PointSize[0.01]},FrameLabel-> {"Space","(Subscript[V, G]), (Subscript[V, LE])"},Frame->{{True,False},{True,False}}],ListPlot[Table[{j,If[Sign[nnList[[i,j]]]==0,Null,varzzList[[i,j]]]},{j,1,nd}],Joined->True,PlotStyle-> {Blue,Thickness[0.003]}],ListPlot[Table[{j,If[Sign[nnList[[i,j]]]==0,Null,varLEList[[i,j]]]},{j,1,nd}],Joined->False,PlotStyle-> {Black,PointSize[0.01]}],ListPlot[Table[{j,If[Sign[nnList[[i,j]]]==0,Null,varLEList[[i,j]]]},{j,1,nd}],Joined->True,PlotStyle-> {Black,Thickness[0.003]}],ListPlot[Table[b σ (Sqrt[Vs]),{x,1,nd}],Joined-> True,PlotStyle-> {Thickness[0.005],Black,Dashed}],Graphics[Inset["D",ImageScaled[{0.185,0.9}],BaseStyle->{Bold,FontSize->14,FontFamily->"Helvetica"}]],BaseStyle->{FontSize->14,FontFamily->"Helvetica"},PlotRange->{{xmin,xmax},{0,.25}},AxesOrigin-> {xmin,0},ImagePadding-> padding]}},ImageSize->700,Frame->False,Spacings->{{0,0},{0,0}}]]

MeannList=Mean[Select[#,#>0&]]&/@nnList//N;

Wdrift gives the predicted cline width under genetic drift (first dashed line on the second picture below), the other dashed line gives the deterministic prediction.
[The first line gives the alternative predictions that arises as approximation between the deterministic limit with selection and neutral limit with drift (see Fig S2), corrected for time; not shown. In this example, the correction for time gives a significant improvement over 200 generations, as genetic drift only slowly degrades (steepens) the clines.]

wdrift=width(1-Exp[-(( σ MeannList[[-1]](Sqrt[s]))/(Sqrt[2]))(1-Exp[(T/(4 (σ^2) (((((MeannList[[-1]])/2)))^2)))]Erfc[((Sqrt[ T])/(2σ ((MeannList[[-1]])/2)))])]);

wdrift=width(1-((0.392 )/(MeannList[[-1]]σ(Sqrt[((α^2)/(2Vs))]))));

Show[GraphicsArray[{Show[Histogram[wListList[[1]],{.1},ChartStyle->Gray,AxesLabel-> {"(Subscript[w, pq])","#"},BaseStyle->{FontFamily-> "Helvetica",FontSize->14}],Graphics[{Dashed,Black,Thickness[0.005],Line[{{width,0},{width,ngenes/3}}]}],PlotRange-> {{0,1.1width},{0,10}},PlotLabel->  dT "generations"],Show[Histogram[wListList[[-1]],{.1},ChartStyle->Gray,AxesLabel-> {"(Subscript[w, pq])","#"},BaseStyle->{FontFamily-> "Helvetica",FontSize->14},PlotRange-> {{0,2width},{0,10}},PlotLabel-> T "generations"],Graphics[{Dashed,Black,Thickness[0.005],Line[{{width,0},{width,ngenes/3}}]}],Graphics[{Dashed,Black,Thickness[0.005],Line[{{wdrift,0},{wdrift,ngenes/3}}]}]]}]]

ρList=((#)/(Plus@@#))&/@nnList;

MeanvarLEList=Table[Plus@@(varLEList[[i]] ρList[[i]]),{i,1,Length[ρList]}];

varLEPList=Table[Cases[varLEList[[i]],Except[0.]]//N,{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

MeanVLECList=Table[Mean[Take[varLEPList[[i]],{3Ceiling[Length[varLEPList[[i]]]/8],Floor[(5/8)Length[varLEPList[[i]]]]}]],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

varZPList=Table[Cases[varzzList[[i]],Except[0.|{}]]//N,{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

MeanVZCList=Table[Mean[Take[varZPList[[i]],{3Ceiling[Length[varZPList[[i]]]/8],Floor[(5/8)Length[varZPList[[i]]]]}]],{i,1,Min[{Alive,Quotient[T,dT]+1}]}];

Show[ListPlot[MeanVZCList,AxesLabel-> {"Time","(OverBar[(Subscript[var, z])]),(OverBar[(Subscript[var, LE])]),(OverBar[(Subscript[var, LD])])"},BaseStyle->{FontSize->14,FontFamily->"Helvetica"},AxesOrigin-> {0.9,0},PlotRange->{{0.9,Quotient[T,dT]+1.2},{-.01,1.2Vopt}},Ticks-> {{{1, 1},{6, Round[5dT]},{11, Round[10dT]},{16, Round[15dT]},{21, Round[20dT]},{51, Round[50dT]},{101, Round[100dT]}},Automatic}],ListPlot[MeanVZCList,Joined-> True],ListPlot[MeanVLECList,PlotStyle-> Red],ListPlot[MeanVLECList,PlotStyle-> Red,Joined-> True],ListPlot[MeanVZCList-MeanVLECList,Joined-> True,PlotStyle->Black],ListPlot[MeanVZCList-MeanVLECList,PlotStyle->Black],Plot[Vopt,{ttttime,0.9,Quotient[T,dT]+1.2},PlotStyle->{Thick, Dashed}]]