Main Model

w11 := 1
w12 := 1+h s
w22 := 1+s
qj := (w22 q q + w12 q (1-q))/(w22 q q + w12 q (1-q) 2 + w11 (1-q)(1-q))
qa := qj (1-m) + m Q
qq := qa  + (1-qa) u
dq := qq-q

q-prime

FullSimplify[qq]

delta - q

FullSimplify[dq]
dqn = -Numerator[Together[dq]];
FullSimplify[CoefficientList[dqn, q]] // MatrixForm

First Derivatives

FullSimplify[D[dq,s]]
!Reduce[% <  0 && 0 ≤  q ≤  1&& 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
FullSimplify[D[dq,u]]
!Reduce[% <  0 && 0 ≤  q ≤  1&& 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
FullSimplify[D[dq,h]]
!Reduce[% <   0 && 0 ≤  q ≤   (1+Sqrt[1+s])^(-1)&& 0≤ h≤ 1 && s≥  0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
FullSimplify[D[dq,h]];
!Reduce[% > 0 && (1+Sqrt[1+s])^(-1) ≤ q ≤ 1&& 0≤ h≤ 1 && s≥  0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
dMig = FullSimplify[D[dq,m]]
dMigTh = ((2 Q)/(1+h (s-2 Q s)+(Sqrt[1+s (2 h (((1-2 Q))^2)-4 (-1+Q) Q+(h^2) (((1-2 Q))^2) s)])));
!Reduce[dMig < 0 &&  0≤ q ≤ dMigTh&& 0≤ h≤ 1 && s≥  0 && 0≤ m ≤ 1 && 0 ≤ Q ≤  1 && 0≤ u ≤  1]
!Reduce[dMig > 0 &&  dMigTh ≤q ≤ 1&& 0≤ h≤ 1 && s≥  0 && 0≤ m ≤ 1 && 0 ≤  Q ≤ 1 && 0≤ u ≤ 1]
FullSimplify[D[dq,Q]]
!Reduce[% <  0 && 0 ≤  q ≤  1&& 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]

Proposition 1

(* Case 1 *)
Solve[dq == 0 /. s->0,q];
qHatLow = q /. %[[1]]
!Reduce[dq ≤  0 && 0 <= q < qHatLow && 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
(* Case 2 *)
dq == 0 /. {u->0,m->0,q->0}

Proposition 2

Limit[(dq /. h->0) , s->Infinity];
Solve[ % == 0, q];
qHatHigh = q /. %[[1]]
!Reduce[dq ≥  0 && qHatHigh < q ≤ 1 && 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1]
(* Tighter Bound *)
Limit[(dq) , s->Infinity];
Solve[ % == 0, q]

Protected Polymorphism

cond = 0≤ h≤ 1 && s≥ 0 && 0≤ m ≤ 1 && 0 ≤ Q ≤ 1 && 0≤ u ≤ 1;
FullSimplify[dq /. q->0]
Reduce[% <= 0&& cond];
FullSimplify[%,cond]
FullSimplify[dq /. q->1]
Reduce[% >= 0&& cond];
FullSimplify[%,cond]

Proposition 3

cond = 0≤ h≤ 1 && s> 0 && 0< m ≤ 1 && 0 ≤ Q ≤ 1 && 0< u ≤ 1;
dqn1 = dqn /. q->1;
dqn0 = dqn /. q->0;
dqnP = Limit[dqn/Abs[q^3], q->Infinity];
dqnN = Limit[dqn/Abs[q^3], q->-Infinity];
(* 1 root or 3 roots *)
!Reduce[ dqn1 >= dqn0 && cond]
!Reduce[ dqn1 > 0 && cond]
!Reduce[ dqn0 < 0 && cond]
(* Case 1 *)
!Reduce[ dqnP < 0 && cond && 1/2 <h ≤ 1] 
!Reduce[ dqnN > 0 && cond && 1/2 <h ≤ 1] 
(* Case 2 *)
Exponent[dqn /. h->1/2,q] == 2
(* Case 3 *)
D[dqn,{q,2}];
!Reduce[% > 0 && cond && 1/3 ≤ h < 1/2 && 0 ≤ q ≤ 1]
(* Case 4 *)
cond4 = cond && 0 ≤ h < 1/3 && s > ((-m-u+m u)/(-h+h m-2 h m Q-h u-h m u+2 h m Q u)) ; 
dqnD = D[dqn, {q,1}];
!Reduce[(dqnD /. q->0) < 0 && cond4]
!Reduce[(dqnD /. q->1) > 0 && cond4]
!Reduce[(dqnD /. q->1) >= (dqnD /. q->0) && cond4]
Limit[dqnD/Abs[q^2], q->-Infinity];
!Reduce[% ≥ 0 && cond4]

S_q(m,h,u,Q)

s /. Solve[dqn == 0,s][[1]];
sStar = FullSimplify[%]
Solve[sStar == 0, m]
Solve[1/sStar ==0,m]

s*/m

Limit[(sStar/m) /. u->0,m->0]
dqApprox = FullSimplify[Normal[Series[dq /. u->0,{q,0,2}]]]
FullSimplify[Discriminant[dqApprox, q]]
Solve[% == 0, s];
Limit[ (s /. %[[1]]) /m, m->0]

Neutral Mutation

w11 := 1
w12 := 1
w22 := 1
qj := (w22 q q + w12 q (1-q))/(w22 q q + w12 q (1-q) 2 + w11 (1-q)(1-q))
qa := qj (1-m) + m Q
qq := qa  + (1-qa) u
dq := qq-q
Solve[dq == 0,q]
FullSimplify[Solve[dq == 0,m]]

Recessive Blindness

w11 := 1
w12 := 1
w22 := 1+s
qj := (w22 q q + w12 q (1-q))/(w22 q q + w12 q (1-q) 2 + w11 (1-q)(1-q))
qa := qj (1-m) + m Q
qq := qa  + (1-qa) u
dq := qq-q
(* Simplification Functions *)
Clear[fSimp,gSimp]
fSimp [a_,b_]:= If[!NumericQ[a]|| a ≠ 0, {a,0},{a,b}]
gSimp[a_,b_] := Map[FromDigits[Reverse[#],b] &, a, {ArrayDepth[a]-1}]
(* Coefficients of dqn *)
dqn = Numerator[Together[dq]]
(* Simplify dqn *)
dqnVars = {s,m,q,Q,u};
dqnCL = CoefficientList[dqn,dqnVars ];
Apply[fSimp,dqnCL,{ArrayDepth[dqnCL]-1}];
dqnA = Fold[gSimp,%, Reverse[dqnVars]];
FullSimplify[CoefficientList[dqnA,q]]
FullSimplify[CoefficientList[dqnA,s]]

Weak Selection

dqnWeak = FullSimplify[Normal[Series[dqnA, {q,0,2}]]]
(* Simplify dqnWeak *)
dqnVars = {s,m,q,Q};
dqnCL = CoefficientList[dqnWeak,dqnVars ];
Apply[fSimp,dqnCL,{ArrayDepth[dqnCL]-1}];
dqnWeakA = Fold[gSimp,%, Reverse[dqnVars]];
FullSimplify[CoefficientList[dqnWeakA,q]]
(* Equilibria *)
dqnWeakRoots = Solve[dqnWeakA==0,q]
(* Roots *)
cond = 0≤ h≤ 1 && s> 0 && 0≤ m < 1 && 0 ≤ Q ≤ 1 && 0< u ≤ 1;
Reduce[Discriminant[dqnWeakA,q] > 0 && cond, s];
FullSimplify[%,cond]
dqnWeakDeriv = D[dqnWeakA,q]
(* lower root is stable *)
dqnWeakDeriv /. dqnWeakRoots[[1]];
!Reduce[(% > 0 || % < -2) && cond]
(* upper root is unstable *)
dqnWeakDeriv /. dqnWeakRoots[[2]];
!Reduce[(% < 0) && cond]
(* Validity *)
FullSimplify[dqnA - dqnWeakA]
!Reduce[ % >0 && cond && Q < q < 1]

Strong Selection

dqnStrongA = -q (q q - (1-m(1-Q))q+m/s)
(* Equilibria *)
dqnStrongRoots = Solve[dqnStrongA== 0,q]
(* Roots *)
cond = 0≤ h≤ 1 && s> 0 && 0< m < 1 && 0 ≤ Q ≤ 1 && 0< u ≤ 1;
Reduce[Discriminant[dqnStrongA,q] > 0 && cond, s]
FullSimplify[%,cond]
dqnStrongDeriv = D[dqnStrongA,q]
(* upper non-zero root is stable *)
dqnStrongDeriv /. dqnStrongRoots[[3]];
!Reduce[(% > 0 || % < -2) && cond]
(* lower non-zero root is unstable *)
dqnStrongDeriv /. dqnStrongRoots[[2]];
!Reduce[(% < 0) && cond]
(* Validity *)
FullSimplify[dqnA - s dqnStrongA]
!Reduce[ % <0 && cond && Q < q < 1]

Additive Blindness with Multiple Alleles

Clear[fSimp,gSimp]
fSimp [a_,b_]:= If[!NumericQ[a]|| a ≠ 0, {a,0},{a,b}]
gSimp[a_,b_] := Map[FromDigits[Reverse[#],b] &, a, {ArrayDepth[a]-1}]

z := s/(2 k)
qj := q (1+z(1-q)+ 2 k q z)/(1+2 k  q z)
qa := qj (1-m) + m Q
qq := qa  + (1-qa) u
dq := qq-q
dqn := Numerator[Together[dq]]
(* Coefficients of dqn *)
dqnVars = {s,m,q,Q,u};
dqnCL = CoefficientList[dqn,dqnVars ];
Apply[fSimp,dqnCL,{ArrayDepth[dqnCL]-1}];
dqnA = Fold[gSimp,%, Reverse[dqnVars]];
FullSimplify[CoefficientList[dqnA,q]]
(* Calculate Equilibrium Frequency *)
dqnRoots = Solve[dqnA == 0, q];
FullSimplify[%]
cond = 0<=u<=1 && 0<=m<=1 && 0<s && 0<=Q <= 1 && k ≥ 1;
!Reduce[ ((q /. dqnRoots[[1]]) < 0 || 1 <(q /. dqnRoots[[1]]))  && cond]
Reduce[ (q /. dqnRoots[[2]]) > 0 && cond]

S*/m

sStar = s /. Solve[dq == 0,s][[1]];
FullSimplify[sStar];
FullSimplify[sStar /. u->0];
Limit[%/m, m->0]