Frequency-dependent Selection and the Evolution of Assortative Mating
Sarah P. Otto, Maria R. Servedio, Scott L. Nuismer 
Genetics 179:1-22 (August 2008)

This notebook performs QLE analyses for group-based and preference-based assortment models.
	
To simplify the calculations, the QLE analysis is split into two phases:  Changes due to selection and changes due to mating and recombination.  Because we keep track only of the leading order terms, small changes due to selection do not impact the small changes due to mating and recombination, allowing us to split the changes at locus A and locus M into these two phases.

Throughout, we let the capital letter O stand for a small term, and we take Taylor series with respect to O.  Thus, when we represent the fitness of genotype aa as 1 + O*(Subscript[S, aa])[(Subscript[P, A])], we are assuming that selection is weak (represented by O) and is multiplied by a term ((Subscript[S, aa])[(Subscript[P, A])]) that is of constant order.  Similarly, we can assume that assortative mating is rare by setting the degree of non-random mating to O *ρ.

Transformations for Changing Variables [ALWAYS ENTER FIRST]

Off[General::"spell1"]
Off[General::"spell"]
<< Graphics`Graphics`

Representing Genome as a vector of sites, GenoVec is a function that generates the list of all possible genotypes if two alleles (0 or 1) could be present at each site:

GenoVec[
          Genome_] := GenoVec[
            Genome] = (For[i = 0, i < Length[Genome], i++, rep = (2^i); 
              repc = 0; 
              For[j = 0, j < (2^Length)[Genome], j++, 
                If[repc < rep, Genos[i][j] = 0]; 
                If[repc ≥ rep && 
                    repc < 2*rep, Genos[i][j] = 1; 
                  If[repc == 2*rep - 1, repc = -1]]; repc++]]; 
            Table[Genos[i - 1][j - 1], {j, 1, (2^Length)[Genome]}, {i, 1, 
                Length[Genome]}]);

For example,we will use the genome {AM,MM,AF,MF} to represent loci A and M on the chromosome inherited from the mother (AM and MM,respectively) and from the father (AF and MF,respectively).

GenoVec[{AM, MM, AF, MF}]

The frequency of genotype ii is given by (Subscript[X, GenoVec[Genome][[ii]]]).

PfromX generates allele frequencies from the genotype frequencies, X, by summing all the X's for genomes that contain 1's in the positions listed in P as 1s:

PfromX[Genome_, 
        P_] := ((∑_(ii = 1)^(Length[GenoVec[Genome]]))(Subscript[X, GenoVec[Genome][[ii]]])*(∑_(jj = 1)^(Length[GenoVec[Genome][[ii]]]))P[[jj]]/2 (GenoVec[Genome][[ii]][[jj]]))

For example, the frequency of allele A is:

PfromX[{AM, MM, AF, MF}, {1, 0, 1, 0}]

DfromX generates association measures among the positions listed in DSet as 1s:

DfromX[Genome_, 
        DSet_] := ((∑_(ii = 1)^(Length[GenoVec[Genome]]))(Subscript[X, GenoVec[Genome][[ii]]])*(∏_(jj = 1)^(Length[DSet]))(((GenoVec[Genome][[ii]][[jj]] - (Subscript[P, Genome[[jj]]])))^DSet)[[jj]])

For example, the departure from Hardy-Weinberg at the A locus would be measured by:

DfromX[{AM, MM, AF, MF}, {1, 0, 1, 0}] /. {(Subscript[P, AM]) -> (Subscript[P, A]), 
        (Subscript[P, AF]) -> (Subscript[P, A]), (Subscript[P, MM]) -> (Subscript[P, M]), 
        (Subscript[P, MF]) -> (Subscript[P, M])}

and the linkage disequilibrium would be:

DfromX[{AM, MM, AF, MF}, {1, 1, 0, 0}] /. {(Subscript[P, AM]) -> (Subscript[P, A]), 
        (Subscript[P, AF]) -> (Subscript[P, A]), (Subscript[P, MM]) -> (Subscript[P, M]), 
        (Subscript[P, MF]) -> (Subscript[P, M])}

By setting (Subscript[P, AM]) -> (Subscript[P, A]), (Subscript[P, AF]) -> (Subscript[P, A]), etc., we have assumed that the genotype frequencies are censused after a point where we have randomized which chromosomes are treated as from the father and from the mother (knowing the origin of the chromosomes does not matter in this model).

Ignoring the sex of origin, there are ten genotype frequencies that must be tracked and that sum to one.  A sufficient set of association measures are then given by:

	\({P\_A == PfromX[{i, j, k, l}, {1, 0, 1, 0}], 
P\_M == 
          PfromX[{i, j, k, l}, {0, 1, 0, 1}], 
D\_{AM, AF} == 
          DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
              0}], 
D\_{MM, MF} == 
          DfromX[{AM, MM, AF, MF}, {0, 1, 0, 
              1}], 
D\_{AM, MM} == 
          DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
              0}], 
D\_{AM, MF} == 
          DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
              1}], 
D\_{AM, MM, AF} == 
          DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
              0}], 
D\_{AM, MM, MF} == 
          DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
              1}], 
D\_{AM, MM, AF, MF} == 
          DfromX[{AM, MM, AF, MF}, {1, 1, 1, 1}]}\)

In addition to the two allele frequencies, these measures describe:
	\(D\_{AM, AF}\):  the departure from Hardy-Weinberg at locus A (the numerator of F in Equation 1 of Otto 2003)
	\(D\_{MM, MF}\): the departure from Hardy-Weinberg at locus M,
	\(D\_{AM, MM}\):  the gametic-phase linkage disequilibrium (freq(AM)*freq(am) - freq(Am)*freq(aM))
	\(D\_{AM, MF}\): the linkage disequilibrium between alleles on homologous chromosomes
	\(D\_{AM, MM, AF}\): the association between the modifier allele M  and the departure from Hardy-Weinberg at the viability locus
	\(D\_{AM, MM, MF}\): the association between the viability allele A and the departure from Hardy-Weinberg at the modifier locus
	\(D\_{AM, MM, AF, MF}\): the association between the departure from Hardy-Weinberg at the modifier locus and the departure from
		Hardy-Weinberg at the viability locus.

The following translates between the diploid two-locus genotype frequencies and the allele and association measures:

\(\(ChangeVars = {X\_{0, 0, 0, 0} -> 
            D\_{AM, MM, AF, MF} + 2\ D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\^2 + 
              2\ D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              2\ D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              2\ D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\^2 + \((\(-1\) + P\_A)\)\^2\ \((\(-1\) + P\_M)\)\^2, 
          X\_{1, 0, 0, 0} -> \(-D\_{AM, MM, AF, MF}\) - 
              D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - D\_{AM, MM, MF}\ P\_A - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A - 
              2\ D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\^2 - \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\^2, 
          X\_{0, 1, 0, 0} -> \(-D\_{AM, MM, AF, MF}\) - 
              2\ D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\^2 - 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM, AF}\ P\_M - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, AF}\ \((\(-1\) + 
                    P\_M)\)\ P\_M - \((\(-1\) + P\_A)\)\^2\ \((\(-1\) + 
                    P\_M)\)\ P\_M, 
          X\_{1, 1, 0, 0} -> 
            D\_{AM, MM, AF, MF} + D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A + 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM, AF}\ P\_M + 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M + 
              D\_{AM, MM}\ P\_A\ P\_M + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M + \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{0, 0, 1, 0} -> \(-D\_{AM, MM, AF, MF}\) - 
              D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - D\_{AM, MM, MF}\ P\_A - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A - 
              2\ D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\^2 - \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\^2, 
          X\_{1, 0, 1, 0} -> 
            D\_{AM, MM, AF, MF} + 2\ D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ P\_A\%2 + 
              2\ D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              2\ D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) + 
              2\ D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\^2 + 
              P\_A\%2\ \((\(-1\) + P\_M)\)\^2, 
          X\_{0, 1, 1, 0} -> 
            D\_{AM, MM, AF, MF} + D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A + 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM, AF}\ P\_M + 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M + 
              D\_{AM, MF}\ P\_A\ P\_M + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M + \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{1, 1, 1, 0} -> \(-D\_{AM, MM, AF, MF}\) - 
              2\ D\_{AM, MM, MF}\ P\_A - D\_{MM, MF}\ P\_A\%2 - 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM, AF}\ P\_M - D\_{AM, MF}\ P\_A\ P\_M - 
              D\_{AM, MM}\ P\_A\ P\_M - 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M - 
              P\_A\%2\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{0, 0, 0, 1} -> \(-D\_{AM, MM, AF, MF}\) - 
              2\ D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\^2 - 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM, AF}\ P\_M - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, AF}\ \((\(-1\) + 
                    P\_M)\)\ P\_M - \((\(-1\) + P\_A)\)\^2\ \((\(-1\) + 
                    P\_M)\)\ P\_M, 
          X\_{1, 0, 0, 1} -> 
            D\_{AM, MM, AF, MF} + D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A + 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM, AF}\ P\_M + 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M + 
              D\_{AM, MF}\ P\_A\ P\_M + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M + \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{0, 1, 0, 1} -> 
            D\_{AM, MM, AF, MF} + 2\ D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\^2 + 
              2\ D\_{AM, MM, AF}\ P\_M + 
              2\ D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M + 
              2\ D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M + 
              D\_{AM, AF}\ P\_M\%2 + \((\(-1\) + P\_A)\)\^2\ P\_M\%2, 
          X\_{1, 1, 0, 1} -> \(-D\_{AM, MM, AF, MF}\) - 
              D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - D\_{AM, MM, MF}\ P\_A - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A - 
              2\ D\_{AM, MM, AF}\ P\_M - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MF}\ P\_A\ P\_M - D\_{AM, MM}\ P\_A\ P\_M - 
              D\_{AM, AF}\ P\_M\%2 - \((\(-1\) + P\_A)\)\ P\_A\ P\_M\%2, 
          X\_{0, 0, 1, 1} -> 
            D\_{AM, MM, AF, MF} + D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) + 
              D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A + 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) + 
              D\_{AM, MM, AF}\ P\_M + 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M + 
              D\_{AM, MM}\ P\_A\ P\_M + 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M + \((\(-1\) + 
                    P\_A)\)\ P\_A\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{1, 0, 1, 1} -> \(-D\_{AM, MM, AF, MF}\) - 
              2\ D\_{AM, MM, MF}\ P\_A - D\_{MM, MF}\ P\_A\%2 - 
              D\_{AM, MM, AF}\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MF}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM}\ P\_A\ \((\(-1\) + P\_M)\) - 
              D\_{AM, MM, AF}\ P\_M - D\_{AM, MF}\ P\_A\ P\_M - 
              D\_{AM, MM}\ P\_A\ P\_M - 
              D\_{AM, AF}\ \((\(-1\) + P\_M)\)\ P\_M - 
              P\_A\%2\ \((\(-1\) + P\_M)\)\ P\_M, 
          X\_{0, 1, 1, 1} -> \(-D\_{AM, MM, AF, MF}\) - 
              D\_{AM, MM, MF}\ \((\(-1\) + P\_A)\) - D\_{AM, MM, MF}\ P\_A - 
              D\_{MM, MF}\ \((\(-1\) + P\_A)\)\ P\_A - 
              2\ D\_{AM, MM, AF}\ P\_M - 
              D\_{AM, MF}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MM}\ \((\(-1\) + P\_A)\)\ P\_M - 
              D\_{AM, MF}\ P\_A\ P\_M - D\_{AM, MM}\ P\_A\ P\_M - 
              D\_{AM, AF}\ P\_M\%2 - \((\(-1\) + P\_A)\)\ P\_A\ P\_M\%2, 
          X\_{1, 1, 1, 1} -> 
            D\_{AM, MM, AF, MF} + 2\ D\_{AM, MM, MF}\ P\_A + 
              D\_{MM, MF}\ P\_A\%2 + 2\ D\_{AM, MM, AF}\ P\_M + 
              2\ D\_{AM, MF}\ P\_A\ P\_M + 2\ D\_{AM, MM}\ P\_A\ P\_M + 
              D\_{AM, AF}\ P\_M\%2 + P\_A\%2\ P\_M\%2};\)\)

ChangeVars can be used to replace the Xs in the above formula for the departure from Hardy-Weinberg to confirm that it equals \(D\_{AM, AF}\):

DfromX[{AM, MM, AF, MF}, {1, 0, 1, 0}] /. {(Subscript[P, AM]) -> (Subscript[P, A]), 
            (Subscript[P, AF]) -> (Subscript[P, A]), (Subscript[P, MM]) -> (Subscript[P, M]), (Subscript[P, MF]) -> (Subscript[P, M])} /. 
        ChangeVars // Factor

and can be used to replace the Xs in the above formula for the linkage disequilibrium to confirm that it equals \(D\_{AM, AM}\):

DfromX[{AM, MM, AF, MF}, {1, 1, 0, 0}] /. {(Subscript[P, AM]) -> (Subscript[P, A]), 
            (Subscript[P, AF]) -> (Subscript[P, A]), (Subscript[P, MM]) -> (Subscript[P, M]), (Subscript[P, MF]) -> (Subscript[P, M])} /. 
        ChangeVars // Factor

After offspring are produced in the life cycle, we randomize which chromosomes are treated as maternal and which are treated as paternal, after which we census the population.  This reduces the number of variables that we must keep track of.  Thus, at the census point, the following genotype frequencies are equivalent:

\(\(SimpleSubs = {X\_{0, 0, 0, 1} -> 
            X\_{0, 1, 0, 0}, 
X\_{0, 0, 1, 0} -> 
            X\_{1, 0, 0, 0}, 
X\_{0, 0, 1, 1} -> 
            X\_{1, 1, 0, 0}, 
X\_{1, 0, 1, 1} -> 
            X\_{1, 1, 1, 0}, 
X\_{0, 1, 1, 1} -> 
            X\_{1, 1, 0, 1}, 
X\_{0, 1, 1, 0} -> 
            X\_{1, 0, 0, 1}};\)\)

QLE results assuming low levels of assortment

PHASE 1: NATURAL SELECTION
(common to all forms of assortative mating)

We start the life cycle after offspring have been produced and after we have randomized which chromosomes we consider to be from the mother and which from the father,because there is no imprinting or other effects that cause maternal and paternal chromosomes to behave differently.The life cycle is then:
	*Natural Selection
	*Assortative Mating
	*Recombination and offspring production
	*Randomization of maternal/paternal chromosome labels within an individual
	*Census

Natural selection

Fitness

Selection is allowed to depend on the genotypic frequencies.  To remind us of this fact, we write the selection coefficient for genotype i at the A locus as (Subscript[S, i])[(Subscript[P, A])], although we technically allow (Subscript[S, i]) to depend on the genotype frequencies at the A locus and not just the allele frequencies.

\(\(W\_{0, 0, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 0, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{0, 1, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 0, 1, 1} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 1, 1, 1} = 1 + O*S\_AA[P\_A];\)\)

The mean fitness:

\(\(W\&_ = 
        Factor[\(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0} + \(X\_{0, 0, 0, 1}\) 
                W\_{0, 0, 0, 1} + \(X\_{0, 0, 1, 0}\) 
                W\_{0, 0, 1, 0} + \(X\_{0, 1, 0, 0}\) 
                W\_{0, 1, 0, 0} + \(X\_{1, 0, 0, 0}\) 
                W\_{1, 0, 0, 0} + \(X\_{0, 0, 1, 1}\) 
                W\_{0, 0, 1, 1} + \(X\_{0, 1, 0, 1}\) 
                W\_{0, 1, 0, 1} + \(X\_{1, 0, 0, 1}\) 
                W\_{1, 0, 0, 1} + \(X\_{0, 1, 1, 0}\) 
                W\_{0, 1, 1, 0} + \(X\_{1, 1, 0, 0}\) 
                W\_{1, 1, 0, 0} + \(X\_{1, 0, 1, 0}\) 
                W\_{1, 0, 1, 0} + \(X\_{0, 1, 1, 1}\) 
                W\_{0, 1, 1, 1} + \(X\_{1, 1, 1, 0}\) 
                W\_{1, 1, 1, 0} + \(X\_{1, 0, 1, 1}\) 
                W\_{1, 0, 1, 1} + \(X\_{1, 1, 0, 1}\) 
                W\_{1, 1, 0, 1} + \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1} /. 
            SimpleSubs];\)\)

Genotype frequencies after selection

\(\(X\_{0, 0, 0, 0}' = \(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = \(X\_{0, 0, 0, 1}\) W\_{0, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = \(X\_{0, 0, 1, 0}\) W\_{0, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = \(X\_{0, 1, 0, 0}\) W\_{0, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = \(X\_{1, 0, 0, 0}\) W\_{1, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = \(X\_{0, 0, 1, 1}\) W\_{0, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = \(X\_{0, 1, 0, 1}\) W\_{0, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = \(X\_{1, 0, 0, 1}\) W\_{1, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = \(X\_{0, 1, 1, 0}\) W\_{0, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = \(X\_{1, 1, 0, 0}\) W\_{1, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = \(X\_{1, 0, 1, 0}\) W\_{1, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = \(X\_{0, 1, 1, 1}\) W\_{0, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = \(X\_{1, 1, 1, 0}\) W\_{1, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = \(X\_{1, 0, 1, 1}\) W\_{1, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = \(X\_{1, 1, 0, 1}\) W\_{1, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)

QLE analysis - natural selection only

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after selection (X'):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))'};

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]]]

Δ(Subscript[P, A]) can be written as Equation 6:

Δ(Subscript[PS, A]) = 
        O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) ((Subscript[P, A]) ((Subscript[S, AA])[(Subscript[P, A])] -  
                    (Subscript[S, Aa])[(Subscript[P, A])]) + (1 -  (Subscript[P, A])) ((Subscript[S, Aa])[(Subscript[P, A])] - 
                    (Subscript[S, aa])[(Subscript[P, A])]));

Factor[%% - Δ(Subscript[PS, A])]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, there is no change in the modifier frequency:

Δ(Subscript[PS, M]) = 
      Simplify[Normal[
          Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]]]

However, to order (O^2), there is a change in the modifier frequency that is driven by three association measures (\(D\_{AM, MM, AF}\), \(D\_{AM, MF}\), and \(D\_{AM, MM}\)):

\(ΔPS\_M = 
      Collect[Normal[
          Series[\((P\_M' - P\_M /. SubDSmall)\), {O, 0, 2}]], {D\_{AM, AF}, 
          D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, 
          D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, Factor]\)

Defining the fitness advantage of homozygotes over heterozygotes due to natural selection as:

(Subscript[H, ns]) = 
      O*(Subscript[S, AA])[(Subscript[P, A])] - 2 O*(Subscript[S, Aa])[(Subscript[P, A])] + O*(Subscript[S, aa])[(Subscript[P, A])] // Factor

we can write the change in modifier frequency due to natural selection as:

\(\(O\ D\_{AM, MM, AF}\ H\_ns + 
        O\ D\_{AM, MM}\ \ ΔPS\_A\/\(\((1 - P\_A)\)\ P\_A\)\  + 
        O\ D\_{AM, MF}\ \ ΔPS\_A\/\(\((1 - P\_A)\)\ P\_A\);\)
\)
Factor[% - Δ(Subscript[PS, M])]

Hence we will need to derive the QLE values for these three association measures.

The following demonstrate that, to leading order, the change in these three association measures due to selection is zero:

\(eqnS\_{AM, MM} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

\(eqnS\_{AM, MF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

\(eqnS\_{AM, MM, AF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

That is, selection does not by itself generate an association between the modifier and the selected loci.

Selection can, however, generate a departure from HW:

\(eqnS\_{AM, AF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - \ D\_{AM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

PHASE 2: MATING

GROUP-BASED MODEL:  General assortment based on three groups
-> With fixed and relative costs

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assumes that assortative mating depends on the "A" locus which is also responsible for coevolution.

Also assumes that assortment entails a cost that decreases with the frequency of the class within which assortment occurs.

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Individuals of genotype i at the A locus join group j with probability group[i,j].  For clarity, we say that Group 1 is the group toward which aa tends to go, group3 is the group toward which AA tends to go.  But the only restriction that we make is that all individuals join some group so that:

group[1, 1] = 1 - group[1, 2] - group[1, 3];
group[2, 2] = 1 - group[2, 1] - group[2, 3];
group[3, 3] = 1 - group[3, 1] - group[3, 2];

We assume that females choose a mate from within her group with a probability ρ, the strength of which is determined by her modifier genotype:

ModMat = {ρ -> (Subscript[ρ, mm]), ρ -> (Subscript[ρ, Mm]), ρ -> (Subscript[ρ, MM])};

First assortative mating occurs according to the genotype at the A locus (mating is written in the order female x male, and it is assumed that females control whether they mate within the genotypic class or randomly).  A small cost is added in proportion to the rarity of the class.  If freq(class) = 1, there is no reduction in fertility.  If freq(class) ~ 0, fertility is reduced by a factor 1-O*c.

The proportion of individuals in each of the three groups is given in the vector freq:

freq = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
freq = 
                freq + {X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 1], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*
                      group[m + o - 1, 
                        3]}
]]]];\)\)
freq = Factor[freq];

The following confirms that the frequencies of all groups sums to one:

stillone = 
      Factor[Sum[freq[[i]], {i, 1, 3}] /. ChangeVars]

The average probability that a female mates within her group for each of the three groups is given by the vector meanpref:

meanpref = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanpref = 
                meanpref + \((O*ρ /. 
                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                              1]\)])\)*{X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 1], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 
                          3]}
]]]];\)\)
meanpref = Factor[meanpref];

A small cost is added in proportion to the rarity of the group.  If freq(group) = 1, there is no reduction in fertility.  If freq(group) ~ 0, fertility is reduced by a factor 1-O*c.  That is, c is a relative cost that declines linearly with the frequency of the group.

In addition, cf is a fixed cost of mating within the group.

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*ρ)\)*\((O*cf)\) - \((O*ρ)\)*\((O*
                                  c)\)*\((group[m + o - 1, 
                                      1]*\((1 - freq[\([1]\)])\) + 
                                  group[m + o - 1, 
                                      2]*\((1 - freq[\([2]\)])\) + 
                                  group[m + o - 1, 
                                      3]*\((1 - freq[\([3]\)])\))\))\) /. 
                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                            1]\)])\)
]]]];\)\)

\(\(meanfertility = 
        1 + Factor[meanfertility - 1] /. 
          X\_{0, 0, 0, 0} + 2\ X\_{0, 1, 0, 0} + X\_{0, 1, 0, 1} + 
              2\ X\_{1, 0, 0, 0} + 2\ X\_{1, 0, 0, 1} + X\_{1, 0, 1, 0} + 
              2\ X\_{1, 1, 0, 0} + 2\ X\_{1, 1, 0, 1} + 2\ X\_{1, 1, 1, 0} + 
              X\_{1, 1, 1, 1} -> 1;\)\)

meanfertilityEQUALS = (1 - 
            cf O (meanpref[[1]] + meanpref[[2]] + 
                  meanpref[[3]]) - 
            c O ((1 - freq[[1]])*
                    meanpref[[1]] + (1 - freq[[2]])*
                    meanpref[[2]] + (1 - freq[[3]])*
                    meanpref[[3]]));

Factor[meanfertility - meanfertilityEQUALS]

Females mate assortatively with probability O*ρ and otherwise mate randomly (we assume that male mating opportunities are not affected by having already assortatively mated):

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((group[m + o - 1, 1]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 1]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([1]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([1]\)])\))\) + 
                              group[m + o - 1, 2]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 2]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([2]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([2]\)])\))\) + 
                              group[m + o - 1, 3]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 3]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([3]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([3]\)])\))\))\) /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)]; 
RM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((X\_{m - 1, n - 1, o - 1, p - 1}'*X\_{q - 1, r - 1, s - 1, t - 1}'*\((1 - O*ρ)\))\) /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)];
]]]]]]]];\)\)

The total frequency of mated pairs composed of {m-1,n-1,o-1,p-1} mothers and {q-1,r-1,s-1,t-1} where these indices run from 1 to 2 is the sum contribution of assortatively mated pairs (AM) and randomly mated pairs (RM):

For[m = 1, 
        m ≤ 2, m++, 
For[n = 1, 
          n ≤ 2, n++, 
For[o = 1, 
            o ≤ 2, o++, 
For[p = 1, 
              p ≤ 2, p++, 
For[q = 1, 
                q ≤ 2, q++, 
For[r = 1, 
                  r ≤ 2, r++, 
For[s = 1, 
                    s ≤ 2, s++, 
For[t = 1, 
                      t ≤ 
                        2, t++, 
(Subscript[Y, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) = ((Subscript[AM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) + 
                              (Subscript[RM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]))/meanfertility]
]]]]]]];

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

Clear[aveρ, Δρ]

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of A in the grouping model:

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) = 0;

Factor[%% - Δ(Subscript[PR, A])]

There is a very small amount of sexual selection induced in this standard grouping model, but it is too small to affect the leading order results for the QLE analysis (this term takes a while to calculate, so we only present the results for complete genotypic grouping with group[i,i] = 1 without costs).  Even this small degree of sexual selection is eliminated in Variant 1 of Appendix A.

Simplify[
      SeriesCoefficient[
          Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall /. 
                                    c -> 0 /. cf -> 0 /. 
                                group[1, 1] -> 1 /. 
                              group[1, 2] -> 0 /. 
                            group[1, 3] -> 0 /. 
                          group[2, 1] -> 0 /. group[2, 2] -> 1 /. 
                      group[2, 3] -> 0 /. group[3, 1] -> 0 /. 
                  group[3, 2] -> 0 /. group[3, 3] -> 1), {O, 0, 
              2}], 2] /. subTrans]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the grouping model either:

Δ(Subscript[PR, M]) = 
      Factor[Normal[Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]] /. 
          subTrans]

To order (O^2), the costs of non-random mating do change the frequency of M:

Δ(Subscript[PR2, M]) = 
      ((O^2)/2)*Collect[D[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 2}] /. 
              O -> 0 /. subTrans, {c, cf}, Factor]

After some rearrangement, the above can be shown to equal - (cf/2) 
          (O^2) Δρ  (1 - (Subscript[P, M])) (Subscript[P, M])  - 
        (1/2) c (O^2) Δρ (1 - 
              (Subscript[P, M])) (Subscript[P, M]) rarity, where rarity is defined as the frequency of each type times the rarity of that type (Equation 8):

rarity = Factor[FreqGroup1*(1 - FreqGroup1) + 
                        FreqGroup2*(1 - FreqGroup2) + 
                        FreqGroup3*(1 - FreqGroup3) /. 
                      FreqGroup1 -> freq[[1]] /. 
                    FreqGroup2 -> freq[[2]] /. 
                  FreqGroup3 -> freq[[3]]] /. ChangeVars /. 
            SubDSmall /. O -> 0 // Factor

The relative and fixed costs explain the reduction in meanfertility below 1:

Collect[
      Normal[Series[(meanfertilityEQUALS - (1 - cf*aveρ*(O^2) -  
                        c* aveρ *rarity* (O^2)) /. ChangeVars /. 
                SubDSmall), {O, 0, 2}]] /. subTrans, c, Factor]

The change in the modifier allele associated with mating can thus be written as:

Factor[Δ(Subscript[PR2, M]) - (- (cf/2) 
              (O^2) Δρ  (1 - 
                  (Subscript[P, M])) (Subscript[P, M])  -  (c/2) 
              (O^2) Δρ  (1 - 
                  (Subscript[P, M])) (Subscript[P, M])  rarity)]

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1 (Equation 7):

\(\(ΔP2\_M = \((\(-\ \(cf\/2\)\) 
                O\^2\ Δρ\ \ \((1 - 
                    P\_M)\)\ P\_M\  - \ \(c\/2\) 
                O\^2\ Δρ\ \ \((1 - 
                    P\_M)\)\ P\_M\ \ rarity)\) + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

We next need to derive the QLE values for the THREE  association measures given above.

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both natural selection and mating) to order O:

Δ(Subscript[P, A]) = 
        O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                  (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]);

     Δ(Subscript[P, M]) = 0;

The following describes the changes in association measures due to mating and recombination, ΔD, taken to linear order in O by a Taylor series.  These must equal zero at QLE (recall that natural selection did not contribute to ΔD to order O):

\(eqn\_{AM, MM} = 
      Collect[\(D[\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                SubDSmall, O] /. O -> 0\) /. subTrans, {O, c, 
          cf, \ Δρ, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MF} = 
      Collect[\(D[\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                SubDSmall, O] /. O -> 0\) /. subTrans, {O, c, 
          cf, \ Δρ, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[\(D[\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM, AF})\) /. 
                SubDSmall, O] /. O -> 0\) /. subTrans, {O, c, 
          cf, \ Δρ, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

The overall change in the modifier frequency:

finalΔ(Subscript[P2, M]) = 
      Collect[Δ(Subscript[P2, M]) /. subQLE /. subTrans, {c, cf}, 
        Factor]

If interested in the average level of homozygosity at QLE:

\(eqn\_{AM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, AF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {O, c, cf, Δρ, \ D\_{AM, AF}, 
          D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, 
          D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, Factor]\)

Adding together the change in \(\(\(\ \)\(D\_{AM, AF}\)\)\) due to natural selection and mating:

\(\(O\ \((\(-1\) + P\_A)\)\^2\ P\_A\%2\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
              S\_AA[P\_A])\) + O\ \((eqn\_{AM, AF})\);\)\)

which can be solved to give the QLE prediction for the departure from Hardy-Weinberg, \(\(\(\ \)\(D\_{AM, AF}\)\)\):

\(D\_{AM, AF} /. \((Solve[% == 0, D\_{AM, AF}] // Flatten)\) // 
      Simplify\)

This is proportional to aveρ and (Subscript[H, ns]) and hence is small when assortative mating is rare (as assumed in SubDSmall).

The change caused by the modifier on \(D\_{AM, AF}\):

Dterm =  % /. aveρ -> ρ;
\(\(ΔD\_{AM, AF} = \((\((\(P\_M\) 
                        Dterm /. {ρ -> ρ\_MM\ })\) + \((\((1 - 
                            P\_M)\) 
                        Dterm /. {ρ -> ρ\_Mm\ })\))\) - \((\((\(P\_M\) Dterm /. {ρ -> ρ\_Mm\ })\) + \((\((1 - P\_M)\) 
                        Dterm /. {ρ -> ρ\_mm\ })\))\) /. subTrans // 
          Factor;\)\)

\(D\_{AM, MM, AF}\) is proportional to \(ΔD\_{AM, AF}\)(Equation 10):

\(\(\(\((1 - P\_M)\)\ P\_M\)\/2\ ΔD\_{AM, AF};\)
\)
\(Factor[% - D\_{AM, MM, AF} /. subQLE]\)

Besides the cost, the main term in finalΔ(Subscript[P2, M]) measures the efficacy of assortative mating in the production of heterozygotes (Equation 11):

FreqAA = (Subscript[P, A]^2);
FreqAa = 2 (1 - (Subscript[P, A])) (Subscript[P, A]);
Freqaa = (((1 - (Subscript[P, A])))^2) ;

θ = 
        Factor[(1/2) (((((FreqAa*group[2, 1]))^2)/FreqGroup1) + ((((FreqAa*group[2, 2]))^2)/FreqGroup2) + ((((FreqAa*group[2, 3]))^2)/FreqGroup3)) - 
                  2 ((((Freqaa*group[1, 1]) (FreqAA*group[3, 1]))/FreqGroup1) + (((Freqaa*group[1, 2]) (FreqAA*group[3, 2]))/FreqGroup2) + (((Freqaa*group[1, 3]) (FreqAA*group[3, 3]))/FreqGroup3)) /. 
                FreqGroup1 -> 
                  group[1, 1]*Freqaa + group[2, 1]* FreqAa + 
                    group[3, 1]* FreqAA /. 
              FreqGroup2 -> 
                group[1, 2]*Freqaa + group[2, 2]* FreqAa + 
                  group[3, 2]* FreqAA /. 
            FreqGroup3 -> 
              group[1, 3]*Freqaa + group[2, 3]* FreqAa + 
                group[3, 3]* FreqAA];

\(ΔD\_{AM, AF}\) is equal to (Δρ θ/2):

\(ΔD\_{AM, AF}/\((Δρ\ θ/2)\) /. 
        subQLE // Factor\)

\(D\_{AM, MM, AF}\) is equal to (Equation 12):

(((1 - (Subscript[P, M])) (Subscript[P, M]))/2) (((Δρ θ)/2));

\(Factor[% - D\_{AM, MM, AF} /. subQLE]\)

Thus, to order (O^2), the change in the modifier across one generation at QLE can be simply written as:

- (cf/2) 
          (O^2) Δρ  (1 - (Subscript[P, M])) (Subscript[P, M])  -  (c/2) 
          (O^2) Δρ  (1 - (Subscript[P, M])) (Subscript[P, M])  rarity +  
        (1/4) (O^2) Δρ  (1 - 
              (Subscript[P, M])) (Subscript[P, M]) θ ((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[S, AA])[(Subscript[P, A])]) ;

    
% - finalΔ(Subscript[P2, M]) // Factor

Thus, as long as costs are small enough, the modifier spreads if the heterozygote is less fit than the average of the homozygotes (underdominance or partial recessivity of the more fit allele).  Furthermore, we know that the A locus will tend to be polymorphic whenever both fixation states are unstable.  That is, when (Subscript[S, Aa])[0]  >  (Subscript[S, aa])[0] and  (Subscript[S, Aa])[1]  >  (Subscript[S, AA])[1].

Without frequency dependence, the condition for both fixation states to be unstable guarantees that there is overdominance at all allele frequencies.  In this case, assortative mating is selected against (finalΔ(Subscript[P2, M]) < 0).

Appendix A Variant 1: General assortment based on three groups
-> Mated males do not join random mating pool

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assumes that assortative mating depends on the "A" locus which is also responsible for coevolution.

Also assumes that assortment entails a cost that decreases with the frequency of the class within which assortment occurs.

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Individuals of genotype i at the A locus join group j with probability group[i,j].  For clarity, we say that Group 1 is the group toward which aa tends to go, group3 is the group toward which AA tends to go.  But the only restriction that we make is that all individuals join some group so that:

group[1, 1] = 1 - group[1, 2] - group[1, 3];
group[2, 2] = 1 - group[2, 1] - group[2, 3];
group[3, 3] = 1 - group[3, 1] - group[3, 2];

We assume that females choose a mate from within her group with a probability ρ, the strength of which is determined by her modifier genotype:

ModMat = {ρ -> (Subscript[ρ, mm]), ρ -> (Subscript[ρ, Mm]), ρ -> (Subscript[ρ, MM])};

First assortative mating occurs according to the genotype at the A locus (mating is written in the order female x male, and it is assumed that females control whether they mate within the genotypic class or randomly).  A small cost is added in proportion to the rarity of the class.  If freq(class) = 1, there is no reduction in fertility.  If freq(class) ~ 0, fertility is reduced by a factor 1-O*c.

The proportion of individuals in each of the three groups is given in the vector freq:

freq = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
freq = 
                freq + {X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 1], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*
                      group[m + o - 1, 
                        3]}
]]]];\)\)
freq = Factor[freq];

The following confirms that the frequencies of all groups sums to one:

stillone = 
      Factor[Sum[freq[[i]], {i, 1, 3}] /. ChangeVars]

The average probability that a female mates within her group for each of the three groups is given by the vector meanpref:

meanpref = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanpref = 
                meanpref + \((O*ρ /. 
                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                              1]\)])\)*{X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 1], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 
                          3]}
]]]];\)\)
meanpref = Factor[meanpref];

A small cost is added in proportion to the rarity of the group.  If freq(group) = 1, there is no reduction in fertility.  If freq(group) ~ 0, fertility is reduced by a factor 1-O*c.  That is, c is a relative cost that declines linearly with the frequency of the group.

In addition, cf is a fixed cost of mating within the group.

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*ρ)\)*\((O*cf)\) - \((O*ρ)\)*\((O*
                                  c)\)*\((group[m + o - 1, 
                                      1]*\((1 - freq[\([1]\)])\) + 
                                  group[m + o - 1, 
                                      2]*\((1 - freq[\([2]\)])\) + 
                                  group[m + o - 1, 
                                      3]*\((1 - freq[\([3]\)])\))\))\) /. 
                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                            1]\)])\)
]]]];\)\)

meanfertility = 1 + Factor[meanfertility - 1];

Females mate assortatively with probability O*ρ and otherwise mate randomly (we now assume that male mating opportunities are reduced to the extent that they have already assortatively mated):

\(\(For[q = 1, 
        q ≤ 2, \(q++\), 
For[r = 1, 
          r ≤ 2, \(r++\), 
For[s = 1, 
            s ≤ 2, \(s++\), 
For[t = 1, 
              t ≤ 
                2, \(t++\), 
newMale\_{q - 1, r - 1, s - 1, t - 1} = X\_{q - 1, r - 1, s - 1, t - 1}'
]]]];\)\)

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((group[m + o - 1, 1]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 1]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([1]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([1]\)])\))\) + 
                              group[m + o - 1, 2]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 2]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([2]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([2]\)])\))\) + 
                              group[m + o - 1, 3]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 3]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*
                                O*ρ/
                                  freq[\([3]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([3]\)])\))\))\) /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)]; 
newMale\_{q - 1, r - 1, s - 1, t - 1} = newMale\_{q - 1, r - 1, s - 1, t - 1} - 
                          AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)
]]]]]]]];\)\)

freqMale = 0;
\(\(For[q = 1, 
        q ≤ 2, \(q++\), 
For[r = 1, 
          r ≤ 2, \(r++\), 
For[s = 1, 
            s ≤ 2, \(s++\), 
For[t = 1, 
              t ≤ 2, \(t++\), 
freqMale = 
                freqMale + 
                  newMale\_{q - 1, r - 1, s - 1, t - 1}
]]]];\)\)
freqMale = Factor[freqMale];

\(\(For[q = 1, 
        q ≤ 2, \(q++\), 
For[r = 1, 
          r ≤ 2, \(r++\), 
For[s = 1, 
            s ≤ 2, \(s++\), 
For[t = 1, 
              t ≤ 
                2, \(t++\), 
newMale\_{q - 1, r - 1, s - 1, t - 1} = newMale\_{q - 1, r - 1, s - 1, t - 1}/
                  freqMale
]]]];\)\)

Females who have not assortatively mated then mate randomly (we assume that male mating opportunities are not affected by having already assortatively mated):

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) + \((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - 
                                        O*ρ /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                                  newMale\_{q - 1, r - 1, s - 1, t - 1})\))\)/
                          meanfertility]
]]]]]]];\)\)

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

Clear[aveρ, Δρ]

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of A in the grouping model:

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) = 0;

Factor[%% - Δ(Subscript[PR, A])]

Now there is no sexual selection induced on the frequency of A, even to smaller order (this term takes a while to calculate, so we only present the results without costs, which cannot alter the frequency of A to order (O^2),  when assortment is rare, costs are small, and association measures are small):

Simplify[
      SeriesCoefficient[
          Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall /. c -> 0 /. 
                cf -> 0), {O, 0, 2}], 2] /. subTrans]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) = 0;

Factor[%% - Δ(Subscript[PR, A])]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the grouping model either:

Δ(Subscript[PR, M]) = 
      Simplify[Normal[Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]] /. 
          subTrans]

To order (O^2), the costs of non-random mating do change the frequency of M:

\(ΔPR2\_M = 
      O\^2\/2*Collect[\(D[\((P\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
              O -> 0\) /. subTrans, {c, cf, D\_{AM, AF}, D\_{MM, MF}, 
            D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
            D\_{AM, MM, AF, MF}}, Factor]\)

Because of memory problems, the above Taylor series was decomposed into a component without D terms plus each of the D terms separately (which didn't contribute in this case).  Note that DxD terms should not be present in the Taylor series to order (O^2) as there must be an order O term proportional to the effect of the modifier.

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
answer = 
      ((O^2)/2)*Collect[D[((Subscript[PD1, M])' - (Subscript[P, M]) /. SubD1), {O, 2}] /. 
              O -> 0 /. subTrans, {c, cf}, Factor]

This corresponds to -(1/2) c (O^2) Δρ (1 - 
            (Subscript[P, M])) (Subscript[P, M]) rarity, where rarity is defined below.

As "answer" contains terms involving c and cf, which are order (O^2)because the change in the modifier is also small, we next quit the kernel, assume the c's are 0 and collect the terms that depend not on the c's but on the D's (which are all zero):

cf = 0;
c = 0;

\(\(SubD1 = {D\_{AM, AF} -> O*D\_{AM, AF}, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> O*D\_{AM, MM}, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> 0};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(\(SubD1 = {D\_{AM, AF} -> 0, D\_{MM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF, MF} -> 
            O*D\_{AM, MM, AF, MF}};\)\)
ChangeVarsD1 = ChangeVars /. SubD1 /. 
          O -> 1;
(Subscript[PD1, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVarsD1;
\(O\^2\/2*
      Collect[\(D[\((PD1\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both selection and mating) to order O:

Δ(Subscript[P, A]) = 
        O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                  (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]);

     Δ(Subscript[P, M]) = 0;

The QLE association measures will be used to give the overall change in the modifier to order (O^2):

Δ(Subscript[PR2, M]) = 
        (1/2) (O^2) (cf Δρ (-1 + (Subscript[P, M])) (Subscript[P, M]) - 
              2 c Δρ (-group[1, 2] + 
                    group[1, 2]^2 - group[1, 3] + group[1, 2] group[1, 3] + 
                    group[1, 3]^2 - 2 (Subscript[P, A]) + 6 group[1, 2] (Subscript[P, A]) - 
                    4 group[1, 2]^2 (Subscript[P, A]) + 4 group[1, 3] (Subscript[P, A]) - 
                    4 group[1, 2] group[1, 3] (Subscript[P, A]) - 
                    4 group[1, 3]^2 (Subscript[P, A]) + 2 group[2, 1] (Subscript[P, A]) - 
                    4 group[1, 2] group[2, 1] (Subscript[P, A]) - 
                    2 group[1, 3] group[2, 1] (Subscript[P, A]) - 
                    2 group[1, 2] group[2, 3] (Subscript[P, A]) + 
                    2 group[1, 3] group[2, 3] (Subscript[P, A]) + 5 (Subscript[P, A]^2) - 
                    12 group[1, 2] (Subscript[P, A]^2) + 6 group[1, 2]^2 (Subscript[P, A]^2) - 
                    5 group[1, 3] (Subscript[P, A]^2) + 
                    6 group[1, 2] group[1, 3] (Subscript[P, A]^2) + 
                    6 group[1, 3]^2 (Subscript[P, A]^2) - 10 group[2, 1] (Subscript[P, A]^2) + 
                    12 group[1, 2] group[2, 1] (Subscript[P, A]^2) + 
                    6 group[1, 3] group[2, 1] (Subscript[P, A]^2) + 
                    4 group[2, 1]^2 (Subscript[P, A]^2) - 4 group[2, 3] (Subscript[P, A]^2) + 
                    6 group[1, 2] group[2, 3] (Subscript[P, A]^2) - 
                    6 group[1, 3] group[2, 3] (Subscript[P, A]^2) + 
                    4 group[2, 1] group[2, 3] (Subscript[P, A]^2) + 
                    4 group[2, 3]^2 (Subscript[P, A]^2) + group[3, 1] (Subscript[P, A]^2) - 
                    group[1, 2] group[3, 1] (Subscript[P, A]^2) - 
                    2 group[1, 3] group[3, 1] (Subscript[P, A]^2) + 
                    group[1, 2] group[3, 2] (Subscript[P, A]^2) - 
                    group[1, 3] group[3, 2] (Subscript[P, A]^2) - 6 (Subscript[P, A]^3) + 
                    10 group[1, 2] (Subscript[P, A]^3) - 4 group[1, 2]^2 (Subscript[P, A]^3) + 
                    2 group[1, 3] (Subscript[P, A]^3) - 
                    4 group[1, 2] group[1, 3] (Subscript[P, A]^3) - 
                    4 group[1, 3]^2 (Subscript[P, A]^3) + 14 group[2, 1] (Subscript[P, A]^3) - 
                    12 group[1, 2] group[2, 1] (Subscript[P, A]^3) - 
                    6 group[1, 3] group[2, 1] (Subscript[P, A]^3) - 
                    8 group[2, 1]^2 (Subscript[P, A]^3) + 10 group[2, 3] (Subscript[P, A]^3) - 
                    6 group[1, 2] group[2, 3] (Subscript[P, A]^3) + 
                    6 group[1, 3] group[2, 3] (Subscript[P, A]^3) - 
                    8 group[2, 1] group[2, 3] (Subscript[P, A]^3) - 
                    8 group[2, 3]^2 (Subscript[P, A]^3) - 2 group[3, 1] (Subscript[P, A]^3) + 
                    2 group[1, 2] group[3, 1] (Subscript[P, A]^3) + 
                    4 group[1, 3] group[3, 1] (Subscript[P, A]^3) + 
                    2 group[2, 1] group[3, 1] (Subscript[P, A]^3) - 
                    2 group[2, 3] group[3, 1] (Subscript[P, A]^3) + 
                    2 group[3, 2] (Subscript[P, A]^3) - 
                    2 group[1, 2] group[3, 2] (Subscript[P, A]^3) + 
                    2 group[1, 3] group[3, 2] (Subscript[P, A]^3) - 
                    2 group[2, 1] group[3, 2] (Subscript[P, A]^3) - 
                    4 group[2, 3] group[3, 2] (Subscript[P, A]^3) + 3 (Subscript[P, A]^4) - 
                    3 group[1, 2] (Subscript[P, A]^4) + group[1, 2]^2 (Subscript[P, A]^4) + 
                    group[1, 2] group[1, 3] (Subscript[P, A]^4) + 
                    group[1, 3]^2 (Subscript[P, A]^4) - 6 group[2, 1] (Subscript[P, A]^4) + 
                    4 group[1, 2] group[2, 1] (Subscript[P, A]^4) + 
                    2 group[1, 3] group[2, 1] (Subscript[P, A]^4) + 
                    4 group[2, 1]^2 (Subscript[P, A]^4) - 6 group[2, 3] (Subscript[P, A]^4) + 
                    2 group[1, 2] group[2, 3] (Subscript[P, A]^4) - 
                    2 group[1, 3] group[2, 3] (Subscript[P, A]^4) + 
                    4 group[2, 1] group[2, 3] (Subscript[P, A]^4) + 
                    4 group[2, 3]^2 (Subscript[P, A]^4) - 
                    group[1, 2] group[3, 1] (Subscript[P, A]^4) - 
                    2 group[1, 3] group[3, 1] (Subscript[P, A]^4) - 
                    2 group[2, 1] group[3, 1] (Subscript[P, A]^4) + 
                    2 group[2, 3] group[3, 1] (Subscript[P, A]^4) + 
                    group[3, 1]^2 (Subscript[P, A]^4) - 3 group[3, 2] (Subscript[P, A]^4) + 
                    group[1, 2] group[3, 2] (Subscript[P, A]^4) - 
                    group[1, 3] group[3, 2] (Subscript[P, A]^4) + 
                    2 group[2, 1] group[3, 2] (Subscript[P, A]^4) + 
                    4 group[2, 3] group[3, 2] (Subscript[P, A]^4) + 
                    group[3, 1] group[3, 2] (Subscript[P, A]^4) + 
                    group[3, 2]^2 (Subscript[P, A]^4)) (-1 + 
                    (Subscript[P, M])) (Subscript[P, M]));

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

Hence we need to derive the QLE values for the THREE  association measures given above.

(Be careful: even though we assume that maternal/paternal chromosomes are immaterial (e.g., \(X\_{0, 0, 1, 0}\)acts like \(X\_{1, 0, 0, 0}\)), it is not the case that they are equal in frequency at the end of the life cycle ((\(X\_{0, 0, 1, 0}\))''≠(\(X\_{1, 0, 0, 0}\))'').  Thus, do not make the SimpleSubs substitution at the end of the life cycle, only at the beginning.  Effectively, we add another stage in the life cycle where we set \(X\_{0, 0, 1, 0}''\) and \(X\_{1, 0, 0, 0}''\)to their average, as the subsequent generation only depends on their average (or their sum).)

The following must equal zero at QLE:

Note that because of memory problems in the following, they were evaluated without costs of assortment, which cannot enter into these equations because the cost terms are order (O^2) for weak assortative mating (assuming c and cf are order O), while these equations are identifying the genetic associations to linear order, O.

cf = 0;
c = 0;

\(eqn\_{AM, MM} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                      1}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - 
                      D\_{AM, MM, AF})\) /. SimpleSubs\) /. SubDSmall, O] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

Clear[c, cf]

finalΔ(Subscript[P2, M]) = 
      Collect[Δ(Subscript[P2, M]) /. subQLE /. subTrans, {c, cf}, 
        Factor]

Thus, as long as costs are small enough, the modifier spreads if the heterozygote is less fit than the average of the homozygotes (underdominance or partial recessivity of the more fit allele).  Furthermore, we know that the A locus will tend to be polymorphic whenever both fixation states are unstable.  That is, when (Subscript[S, Aa])[0]  >  (Subscript[S, aa])[0] and  (Subscript[S, Aa])[1]  >  (Subscript[S, AA])[1].

Without frequency dependence, the condition for both fixation states to be unstable guarantees that there is overdominance at all allele frequencies.  In this case, assortative mating is selected against (finalΔ(Subscript[P2, M]) < 0).

Note that the cost is related to the frequency of each type times the rarity of that type:

rarity = Factor[FreqGroup1*(1 - FreqGroup1) + 
                        FreqGroup2*(1 - FreqGroup2) + 
                        FreqGroup3*(1 - FreqGroup3) /. 
                      FreqGroup1 -> freq[[1]] /. 
                    FreqGroup2 -> freq[[2]] /. 
                  FreqGroup3 -> freq[[3]]] /. ChangeVars /. 
            SubDSmall /. O -> 0 // Factor

Besides the cost, the remainder of finalΔ(Subscript[P2, M]) measures the efficacy of assortative mating in the production of heterozygotes:

FreqAA = (Subscript[P, A]^2);
FreqAa = 2 (1 - (Subscript[P, A])) (Subscript[P, A]);
Freqaa = (((1 - (Subscript[P, A])))^2) ;

θ = 
        Factor[(1/2) (((((FreqAa*group[2, 1]))^2)/FreqGroup1) + ((((FreqAa*group[2, 2]))^2)/FreqGroup2) + ((((FreqAa*group[2, 3]))^2)/FreqGroup3)) - 
                  2 ((((Freqaa*group[1, 1]) (FreqAA*group[3, 1]))/FreqGroup1) + (((Freqaa*group[1, 2]) (FreqAA*group[3, 2]))/FreqGroup2) + (((Freqaa*group[1, 3]) (FreqAA*group[3, 3]))/FreqGroup3)) /. 
                FreqGroup1 -> 
                  group[1, 1]*Freqaa + group[2, 1]* FreqAa + 
                    group[3, 1]* FreqAA /. 
              FreqGroup2 -> 
                group[1, 2]*Freqaa + group[2, 2]* FreqAa + 
                  group[3, 2]* FreqAA /. 
            FreqGroup3 -> 
              group[1, 3]*Freqaa + group[2, 3]* FreqAa + 
                group[3, 3]* FreqAA];

- (cf/2) 
          (O^2) Δρ  (1 - (Subscript[P, M])) (Subscript[P, M]) -  (c/2) 
          (O^2) Δρ  (1 - (Subscript[P, M])) (Subscript[P, M])  rarity + 
        (1/4) (O^2) Δρ θ (1 - 
              (Subscript[P, M])) (Subscript[P, M]) ((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[S, AA])[(Subscript[P, A])]) ;

% - finalΔ(Subscript[P2, M]) // Factor

Appendix A Variant 2:  General assortment based on four groups
-> Random mating is a separate group

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assumes that assortative mating depends on the "A" locus which is also responsible for coevolution.

Also assumes that assortment entails a cost that decreases with the frequency of the class within which assortment occurs.

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Individuals of genotype i at the A locus join one of the three groups, j, with probability (O*ρ)*g[i,j] where g[i,j] is the probability of joining group j given that the individual doesn't join the lek and g[i,1]+g[i,2]+g[i,3] = 1.  For clarity, we say that Group 1 is the group toward which aa tends to go, group3 is the group toward which AA tends to go.  The ones that don't join a group, enter the lek:

g[1, 1] = 1 - g[1, 2] - g[1, 3];
g[2, 2] = 1 - g[2, 1] - g[2, 3];
g[3, 3] = 1 - g[3, 1] - g[3, 2];

group[1, 1] = (O*ρ)*g[1, 1];
group[2, 1] = (O*ρ)*g[2, 1];
group[3, 1] = (O*ρ)*g[3, 1];
group[1, 2] = (O*ρ)*g[1, 2];
group[2, 2] = (O*ρ)*g[2, 2];
group[3, 2] = (O*ρ)*g[3, 2];
group[1, 3] = (O*ρ)*g[1, 3];
group[2, 3] = (O*ρ)*g[2, 3];
group[3, 3] = (O*ρ)*g[3, 3];
group[1, 4] = 1 - (O*ρ);
group[2, 4] = 1 - (O*ρ);
group[3, 4] = 1 - (O*ρ);

We assume that females choose a mate from within her group with a probability ρ, the strength of which is determined by her modifier genotype:

ModMat = {ρ -> (Subscript[ρ, mm]), ρ -> (Subscript[ρ, Mm]), ρ -> (Subscript[ρ, MM])};

First assortative mating occurs according to the genotype at the A locus (mating is written in the order female x male, and it is assumed that females control whether they mate within the genotypic class or randomly).  A small cost is added in proportion to the rarity of the class.  If freq(class) = 1, there is no reduction in fertility.  If freq(class) ~ 0, fertility is reduced by a factor 1 -O*c.

The proportion of individuals in each of the three groups is given in the vector freq (as there are no sex differences among the offspring, these apply to males and females):

freq = {0, 0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
freq = 
                freq + {X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 
                            1] /. ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 2] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 3] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 4] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)])\)}
]]]];\)\)
freq = Factor[freq];

The following confirms that the frequencies of all groups sums to one:

stillone = 
      Factor[Sum[freq[[i]], {i, 1, 4}] /. ChangeVars]

A small cost is added in proportion to the rarity of the group.  If freq(group) = 1, there is no reduction in fertility.  If freq(group) ~ 0, fertility is reduced by a factor 1-O*c.  That is, c is a relative cost that declines linearly with the frequency of the group.

In addition, cf is a fixed cost for the ability to recognize ones A genotype and group accordinly (proportional to ρ, regardless of where mating takes place).

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*cf)\)*\((O*ρ /. 
                                ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                      1]\)])\) - \((O*
                                c)\)*\((\((group[m + o - 1, 1] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([1]\)])\) + 
\((group[m + o - 1, 2] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([2]\)])\) + 
\((group[m + o - 1, 3] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([3]\)])\) + 
\((group[m + o - 1, 4] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([4]\)])\))\))\))\)
]]]];\)\)

\(\(meanfertility = 
        1 + Factor[
              meanfertility - 1] /. \((X\_{0, 0, 0, 0} + 2\ X\_{0, 1, 0, 0} + 
                X\_{0, 1, 0, 1} + 2\ X\_{1, 0, 0, 0} + 2\ X\_{1, 0, 0, 1} + 
                X\_{1, 0, 1, 0} + 2\ X\_{1, 1, 0, 0} + 2\ X\_{1, 1, 0, 1} + 
                2\ X\_{1, 1, 1, 0} + X\_{1, 1, 1, 1} -> 
              1)\);\)\)

Females always mate within their group or in the lek:

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((\((group[m + o - 1, 1] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 1] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([1]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([1]\)])\))\) + 
\((group[m + o - 1, 2] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 2] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([2]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([2]\)])\))\) + 
\((group[m + o - 1, 3] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 3] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([3]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([3]\)])\))\))\); 
RM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((\((group[m + o - 1, 4] /. ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 4] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([4]\)])\))\)*\((1 - \((O*
                                    cf)\)*\((O*ρ /. 
                                    ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                              O*c*\((1 - 
                                    freq[\([4]\)])\))\)
]]]]]]]];\)\)

The total frequency of mated pairs composed of {m-1,n-1,o-1,p-1} mothers and {q-1,r-1,s-1,t-1} where these indices run from 1 to 2 is:

For[m = 1, 
        m ≤ 2, m++, 
For[n = 1, 
          n ≤ 2, n++, 
For[o = 1, 
            o ≤ 2, o++, 
For[p = 1, 
              p ≤ 2, p++, 
For[q = 1, 
                q ≤ 2, q++, 
For[r = 1, 
                  r ≤ 2, r++, 
For[s = 1, 
                    s ≤ 2, s++, 
For[t = 1, 
                      t ≤ 
                        2, t++, 
(Subscript[Y, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) = ((Subscript[AM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) + 
                              (Subscript[RM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]))/meanfertility]
]]]]]]];

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

Clear[aveρ, Δρ]

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of A in the grouping model:

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) = 0;

Factor[%% - Δ(Subscript[PR, A])]

Now there is no sexual selection induced on the frequency of A, even to smaller order (this term takes a while to calculate, so we only present the results without costs, which cannot alter the frequency of A to order (O^2),  when assortment is rare, costs are small, and association measures are small):

\(O\^2\/2*
      Collect[\(D[\((\(\(P\_A' - P\_A /. SubDSmall\) /. c -> 0\) /. 
                  cf -> 0)\), {O, 2}] /. O -> 0\) /. subTrans, {\ 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the grouping model either:

Δ(Subscript[PR, M]) = 
      Simplify[Normal[Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]] /. 
          subTrans]

To order (O^2), the costs of non-radnom mating mating and recombination do change the frequency of M:

\(ΔPR2\_M = 
      O\^2\/2*Collect[\(D[\((P\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
              O -> 0\) /. subTrans, {c, cf, D\_{AM, AF}, D\_{MM, MF}, 
            D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
            D\_{AM, MM, AF, MF}}, Factor]\)

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both natural selection and mating) to order O:

Δ(Subscript[P, A]) = 
        O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                  (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]);

     Δ(Subscript[P, M]) = 0;

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

The following describes the changes in association measures due to mating and recombination, ΔD, taken to linear order in O by a Taylor series.  These must equal zero at QLE (recall that natural selection did not contribute to ΔD to order O).

Note that because of memory problems in the following, they were evaluated without costs of assortment, which cannot enter into these equations because the cost terms are order (O^2) for weak modifiers (assuming c and cf are order O), while these equations are identifying the genetic associations to linear order, O.

cf = 0;
c = 0;

\(eqn\_{AM, MM} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                      1}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - 
                      D\_{AM, MM, AF})\) /. SimpleSubs\) /. SubDSmall, O] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

Out of interest, the change in \(D\_{AM, AF}\) caused by assortative mating is:

\(eqn\_{AM, AF} = 
Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 
                                      0, 1, 0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, AF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

Adding together the change in \(\(\(\ \)\(D\_{AM, AF}\)\)\) due to natural selection and mating:

\(\(O\ \((\(-1\) + P\_A)\)\^2\ P\_A\%2\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
              S\_AA[P\_A])\) + O\ \((eqn\_{AM, AF})\);\)\)

which can be solved to give the QLE prediction for the departure from Hardy-Weinberg, \(\(\(\ \)\(D\_{AM, AF}\)\)\):

\(D\_{AM, AF} /. \((Solve[% == 0, D\_{AM, AF}] // Flatten)\) // 
      Simplify\)

This is proportional to aveρ and (Subscript[H, ns]) and hence is small when assortative mating is rare (as assumed in SubDSmall).

The change caused by the modifier on \(D\_{AM, AF}\):

Dterm =  % /. aveρ -> ρ;
\(\(ΔD\_{AM, AF} = \((\((\(P\_M\) 
                        Dterm /. {ρ -> ρ\_MM\ })\) + \((\((1 - 
                            P\_M)\) 
                        Dterm /. {ρ -> ρ\_Mm\ })\))\) - \((\((\(P\_M\) Dterm /. {ρ -> ρ\_Mm\ })\) + \((\((1 - P\_M)\) 
                        Dterm /. {ρ -> ρ\_mm\ })\))\) /. subTrans // 
          Factor;\)\)

This is equal to Δθ/2 (defined below):

	\(Factor[
        O*ΔD\_{AM, AF}/\((\ Δθ/2)\)]\)
	1

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

Now instead of (10) we have that \(D\_{AM, MM, AF}\) = \(\((1 - P\_M)\)\ P\_M\ \ ΔD\_{AM, AF}\)

\(\(\(\((1 - 
            P\_M)\)\ P\_M\ \ ΔD\_{AM, AF};\)\(
\)
    \)\)
\(Factor[% - D\_{AM, MM, AF} /. subQLE]\)

This is twice what we saw in the standard grouping model, probably because increased movement to groups happens in both males and females and changes in assortative mating caused by carriers of M not only imply that M-bearing females are more likely to assortatively mate but also M-bearing males are too.  In contrast, in the standard grouping model, the males in a group include all modifier genotypes.

Clear[c, cf]

finalΔ(Subscript[P2, M]) = 
      Collect[Δ(Subscript[P2, M]) /. subQLE /. subTrans, {c, cf}, 
        Simplify]

Note that the cost is related to the frequency of each type times the rarity of that type:

rarity = 
      Factor[Normal[
          Series[FreqGroup1*(1 - FreqGroup1) + 
                            FreqGroup2*(1 - FreqGroup2) + 
                            FreqGroup3*(1 - FreqGroup3) + 
                            FreqGroup4*(1 - FreqGroup4) /. 
                          FreqGroup1 -> freq[[1]] /. 
                        FreqGroup2 -> freq[[2]] /. 
                      FreqGroup3 -> freq[[3]] /. 
                    FreqGroup4 -> freq[[4]] /. ChangeVars /. 
                SubDSmall /. subTrans, {O, 0, 1}]]]

The change in rarity is then:

Δrarity = 
      Factor[(rarity /.  
              aveρ ->  
                aveρ + Δρ) - (rarity)]

Besides the cost, the remainder of finalΔ(Subscript[P2, M]) measures the efficacy of assortative mating in the production of heterozygotes:

FreqAA = (Subscript[P, A]^2);
FreqAa = 2 (1 - (Subscript[P, A])) (Subscript[P, A]);
Freqaa = (((1 - (Subscript[P, A])))^2) ;

θ = 
        Factor[(1/2) (((((FreqAa*group[2, 1]))^2)/FreqGroup1) + ((((FreqAa*group[2, 2]))^2)/FreqGroup2) + ((((FreqAa*group[2, 3]))^2)/FreqGroup3) + ((((FreqAa*group[2, 4]))^2)/FreqGroup4)) - 
                      2 ((((Freqaa*group[1, 1]) (FreqAA*group[3, 1]))/FreqGroup1) + (((Freqaa*group[1, 2]) (FreqAA*group[3, 2]))/FreqGroup2) + (((Freqaa*group[1, 3]) (FreqAA*group[3, 3]))/FreqGroup3) + (((Freqaa*group[1, 4]) (FreqAA*group[3, 4]))/FreqGroup4)) /. 
                    FreqGroup1 -> 
                      group[1, 1]*Freqaa + group[2, 1]* FreqAa + 
                        group[3, 1]* FreqAA /. 
                  FreqGroup2 -> 
                    group[1, 2]*Freqaa + group[2, 2]* FreqAa + 
                      group[3, 2]* FreqAA /. 
                FreqGroup3 -> 
                  group[1, 3]*Freqaa + group[2, 3]* FreqAa + 
                    group[3, 3]* FreqAA /. 
              FreqGroup4 -> 
                group[1, 4]*Freqaa + group[2, 4]* FreqAa + 
                  group[3, 4]* FreqAA /.  ρ -> 
              aveρ];

Δθ = 
      Factor[(θ /. 
              aveρ -> 
                aveρ + Δρ) - (θ)]

(Except for the factor, O Δρ, which is pulled into the Δθ and Δrarity terms in this formulation, the above is identical to θ in the standard model.)

\(\(\(-\(1\/2\)\)\ cf\ O\^2\ Δρ\ \((1 - 
                P\_M)\)\ P\_M - \ \(c\/2\) 
            O\ \((1 - P\_M)\)\ P\_M\ \ Δrarity + 
          O\^2\ \(D\_{AM, MM, AF}\) \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
                S\_AA[P\_A])\) /. 
        subQLE;\)
\)
% - finalΔ(Subscript[P2, M]) // Factor

Note that assortment has twice the effect on \(D\_{AM, MM, AF}\) in this variant model.  When assortment happens within a group and aveρ is small, then males that are in the group are also likely to carry the modifier, doubling the chance that the modifier becomes associated with homozygosity.

-(1/2) cf (O^2) Δρ (1 - 
              (Subscript[P, M])) (Subscript[P, M]) -  (c/2) 
          O (1 - (Subscript[P, M])) (Subscript[P, M])  Δrarity + 
        2 ((1/2) O (1 - 
                  (Subscript[P, M])) (Subscript[P, M]) Δ(θ/2) ((Subscript[S, aa])[
                    (Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
                  (Subscript[S, AA])[(Subscript[P, A])])) ;

% - finalΔ(Subscript[P2, M]) // Factor

Note that there is no cf term in this, because all mating occurs within groups, so all modifier alleles pay the same fixed cost of mating within groups (see below).

Assortative mating
	[Quit kernel and enter this section instead of "Assortative mating" section above.]
-> AS ABOVE BUT RANDOM MATING POOL DOES NOT PAY COSTS

Assumes that assortative mating depends on the "A" locus which is also responsible for coevolution.

Also assumes that assortment entails a cost that decreases with the frequency of the class within which assortment occurs.

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Individuals of genotype i at the A locus join one of the three groups, j, with probability (O*ρ)*g[i,j] where g[i,j] is the probability of joining group j given that the individual doesn't join the lek and g[i,1]+g[i,2]+g[i,3] = 1.  For clarity, we say that Group 1 is the group toward which aa tends to go, group3 is the group toward which AA tends to go.  The ones that don't join a group, enter the lek:

g[1, 1] = 1 - g[1, 2] - g[1, 3];
g[2, 2] = 1 - g[2, 1] - g[2, 3];
g[3, 3] = 1 - g[3, 1] - g[3, 2];

group[1, 1] = (O*ρ)*g[1, 1];
group[2, 1] = (O*ρ)*g[2, 1];
group[3, 1] = (O*ρ)*g[3, 1];
group[1, 2] = (O*ρ)*g[1, 2];
group[2, 2] = (O*ρ)*g[2, 2];
group[3, 2] = (O*ρ)*g[3, 2];
group[1, 3] = (O*ρ)*g[1, 3];
group[2, 3] = (O*ρ)*g[2, 3];
group[3, 3] = (O*ρ)*g[3, 3];
group[1, 4] = 1 - (O*ρ);
group[2, 4] = 1 - (O*ρ);
group[3, 4] = 1 - (O*ρ);

We assume that females choose a mate from within her group with a probability ρ, the strength of which is determined by her modifier genotype:

ModMat = {ρ -> (Subscript[ρ, mm]), ρ -> (Subscript[ρ, Mm]), ρ -> (Subscript[ρ, MM])};

First assortative mating occurs according to the genotype at the A locus (mating is written in the order female x male, and it is assumed that females control whether they mate within the genotypic class or randomly).  A small cost is added in proportion to the rarity of the class.  If freq(class) = 1, there is no reduction in fertility.  If freq(class) ~ 0, fertility is reduced by a factor 1 -O*c.

The proportion of individuals in each of the three groups is given in the vector freq (as there are no sex differences among the offspring, these apply to males and females):

freq = {0, 0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
freq = 
                freq + {X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 
                            1] /. ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 2] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 3] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\), 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*\((group[m + o - 1, 4] /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)])\)}
]]]];\)\)
freq = Factor[freq];

The following confirms that the frequencies of all groups sums to one:

stillone = 
      Factor[Sum[freq[[i]], {i, 1, 4}] /. ChangeVars]

A small cost is added in proportion to the rarity of the group.  If freq(group) = 1, there is no reduction in fertility.  If freq(group) ~ 0, fertility is reduced by a factor 1-O*c.  That is, c is a relative cost that declines linearly with the frequency of the group (not paid in the lek).

In addition, cf is a fixed cost for the ability to recognize ones A genotype and group accordinly (proportional to ρ, regardless of where mating takes place).

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*cf)\)*\((O*ρ /. 
                                ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                      1]\)])\) - \((O*
                                c)\)*\((\((group[m + o - 1, 1] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([1]\)])\) + 
\((group[m + o - 1, 2] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([2]\)])\) + 
\((group[m + o - 1, 3] /. 
                                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*\((1 - 
                                      freq[\([3]\)])\))\))\))\)
]]]];\)\)

\(\(meanfertility = 
        1 + Factor[
              meanfertility - 1] /. \((X\_{0, 0, 0, 0} + 2\ X\_{0, 1, 0, 0} + 
                X\_{0, 1, 0, 1} + 2\ X\_{1, 0, 0, 0} + 2\ X\_{1, 0, 0, 1} + 
                X\_{1, 0, 1, 0} + 2\ X\_{1, 1, 0, 0} + 2\ X\_{1, 1, 0, 1} + 
                2\ X\_{1, 1, 1, 0} + X\_{1, 1, 1, 1} -> 
              1)\);\)\)

Females always mate within their group or in the lek:

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((\((group[m + o - 1, 1] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 1] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([1]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([1]\)])\))\) + 
\((group[m + o - 1, 2] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 2] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([2]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([2]\)])\))\) + 
\((group[m + o - 1, 3] /. 
                                  ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 3] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([3]\)])\)*\((1 - \((O*
                                        cf)\)*\((O*ρ /. 
                                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\) - 
                                  O*c*\((1 - 
                                        freq[\([3]\)])\))\))\); 
RM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((\((group[m + o - 1, 4] /. ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\)*
                              X\_{m - 1, n - 1, o - 1, p - 1}'*\((\((group[
                                        q + s - 1, 4] /. 
                                      ModMat[\([\((r - 1)\) + \((t - 1)\) + 
                                        1]\)])\)*
                                  X\_{q - 1, r - 1, s - 1, t - 1}'/
                                    freq[\([4]\)])\))\)*\((1 - \((O*
                                    cf)\)*\((O*ρ /. 
                                    ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                        1]\)])\))\)
]]]]]]]];\)\)

The total frequency of mated pairs composed of {m-1,n-1,o-1,p-1} mothers and {q-1,r-1,s-1,t-1} where these indices run from 1 to 2 is:

For[m = 1, 
        m ≤ 2, m++, 
For[n = 1, 
          n ≤ 2, n++, 
For[o = 1, 
            o ≤ 2, o++, 
For[p = 1, 
              p ≤ 2, p++, 
For[q = 1, 
                q ≤ 2, q++, 
For[r = 1, 
                  r ≤ 2, r++, 
For[s = 1, 
                    s ≤ 2, s++, 
For[t = 1, 
                      t ≤ 
                        2, t++, 
(Subscript[Y, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) = ((Subscript[AM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) + 
                              (Subscript[RM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]))/meanfertility]
]]]]]]];

QLE analysis
	[Enter this section instead of "QLE analysis" section above.]
-> AS ABOVE BUT RANDOM MATING POOL DOES NOT PAY COSTS

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

Clear[aveρ, Δρ]

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of A in the grouping model:

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) = 0;

Factor[%% - Δ(Subscript[PR, A])]

Now there is no sexual selection induced on the frequency of A, even to smaller order (this term takes a while to calculate, so we only present the results without costs, which cannot alter the frequency of A to order (O^2),  when assortment is rare, costs are small, and association measures are small):

\(O\^2\/2*
      Collect[\(D[\((\(\(P\_A' - P\_A /. SubDSmall\) /. c -> 0\) /. 
                  cf -> 0)\), {O, 2}] /. O -> 0\) /. subTrans, {\ 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the grouping model either:

Δ(Subscript[PR, M]) = 
      Simplify[Normal[Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]] /. 
          subTrans]

To order (O^2), the costs of non-random mating do change the frequency of M:

\(ΔPR2\_M = 
      O\^2\/2*Collect[\(D[\((P\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
              O -> 0\) /. subTrans, {c, cf, D\_{AM, AF}, D\_{MM, MF}, 
            D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
            D\_{AM, MM, AF, MF}}, Factor]\)

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

We next need to derive the QLE values for the THREE  association measures given above.

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both natural selection and mating) to order O:

Δ(Subscript[P, A]) = 
        O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                  (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]);

     Δ(Subscript[P, M]) = 0;

The following describes the changes in association measures due to mating and recombination, ΔD, taken to linear order in O by a Taylor series.  These must equal zero at QLE (recall that natural selection did not contribute to ΔD to order O).

Note that because of memory problems in the following, they were evaluated without costs of assortment, which cannot enter into these equations because the cost terms are order (O^2) for weak modifiers (assuming c and cf are order O), while these equations are identifying the genetic associations to linear order, O.

cf = 0;
c = 0;

\(eqn\_{AM, MM} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                      1}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - 
                      D\_{AM, MM, AF})\) /. SimpleSubs\) /. SubDSmall, O] /. 
            O -> 0\) /. subTrans, {D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

Out of interest, the change in \(D\_{AM, AF}\) caused by assortative mating is:

\(eqn\_{AM, AF} = 
Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 
                                      0, 1, 0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, AF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

Adding together the change in \(\(\(\ \)\(D\_{AM, AF}\)\)\) due to natural selection and mating:

\(\(O\ \((\(-1\) + P\_A)\)\^2\ P\_A\%2\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
              S\_AA[P\_A])\) + O\ \((eqn\_{AM, AF})\);\)\)

which can be solved to give the QLE prediction for the departure from Hardy-Weinberg, \(\(\(\ \)\(D\_{AM, AF}\)\)\):

\(D\_{AM, AF} /. \((Solve[% == 0, D\_{AM, AF}] // Flatten)\) // 
      Simplify\)

This is proportional to aveρ and (Subscript[H, ns]) and hence is small when assortative mating is rare (as assumed in SubDSmall).

The change caused by the modifier on \(D\_{AM, AF}\):

Dterm =  % /. aveρ -> ρ;
\(\(ΔD\_{AM, AF} = \((\((\(P\_M\) 
                        Dterm /. {ρ -> ρ\_MM\ })\) + \((\((1 - 
                            P\_M)\) 
                        Dterm /. {ρ -> ρ\_Mm\ })\))\) - \((\((\(P\_M\) Dterm /. {ρ -> ρ\_Mm\ })\) + \((\((1 - P\_M)\) 
                        Dterm /. {ρ -> ρ\_mm\ })\))\) /. subTrans // 
          Factor;\)\)

This is equal to Δθ/2 (defined below):

	\(Factor[
        O*ΔD\_{AM, AF}/\((\ Δθ/2)\)]\)
	1

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

Now instead of (10) we have that \(D\_{AM, MM, AF}\) = \(\((1 - P\_M)\)\ P\_M\ \ ΔD\_{AM, AF}\)

\(\(\(\((1 - 
            P\_M)\)\ P\_M\ \ ΔD\_{AM, AF};\)\(
\)
    \)\)
\(Factor[% - D\_{AM, MM, AF} /. subQLE]\)

This is twice what we saw in the standard grouping model, probably because increased movement to groups happens in both males and females.  Thus, changes in assortative mating caused by carriers of M not only imply that M-bearing females are more likely to assortatively mate but also M-bearing males are too.  In contrast, in the standard grouping model, the males in a group include all modifier genotypes.

Clear[c, cf]

finalΔ(Subscript[P2, M]) = 
      Collect[Δ(Subscript[P2, M]) /. subQLE /. subTrans, {c, cf}, 
        Factor]

Note that the cost is related to the frequency of each type times the rarity of that type (but not in the fourth random mating group):

rarity = 
      Factor[Normal[
          Series[FreqGroup1*(1 - FreqGroup1) + 
                          FreqGroup2*(1 - FreqGroup2) + 
                          FreqGroup3*(1 - FreqGroup3) /. 
                        FreqGroup1 -> freq[[1]] /. 
                      FreqGroup2 -> freq[[2]] /. 
                    FreqGroup3 -> freq[[3]] /. ChangeVars /. 
                SubDSmall /. subTrans, {O, 0, 1}]]]

The change in rarity is then:

Δrarity = 
      Factor[(rarity /.  
              aveρ ->  
                aveρ + Δρ) - (rarity)]

Besides the cost, the remainder of finalΔ(Subscript[P2, M]) measures the efficacy of assortative mating in the production of heterozygotes:

FreqAA = (Subscript[P, A]^2);
FreqAa = 2 (1 - (Subscript[P, A])) (Subscript[P, A]);
Freqaa = (((1 - (Subscript[P, A])))^2) ;

θ = 
        Factor[(1/2) (((((FreqAa*group[2, 1]))^2)/FreqGroup1) + ((((FreqAa*group[2, 2]))^2)/FreqGroup2) + ((((FreqAa*group[2, 3]))^2)/FreqGroup3) + ((((FreqAa*group[2, 4]))^2)/FreqGroup4)) - 
                      2 ((((Freqaa*group[1, 1]) (FreqAA*group[3, 1]))/FreqGroup1) + (((Freqaa*group[1, 2]) (FreqAA*group[3, 2]))/FreqGroup2) + (((Freqaa*group[1, 3]) (FreqAA*group[3, 3]))/FreqGroup3) + (((Freqaa*group[1, 4]) (FreqAA*group[3, 4]))/FreqGroup4)) /. 
                    FreqGroup1 -> 
                      group[1, 1]*Freqaa + group[2, 1]* FreqAa + 
                        group[3, 1]* FreqAA /. 
                  FreqGroup2 -> 
                    group[1, 2]*Freqaa + group[2, 2]* FreqAa + 
                      group[3, 2]* FreqAA /. 
                FreqGroup3 -> 
                  group[1, 3]*Freqaa + group[2, 3]* FreqAa + 
                    group[3, 3]* FreqAA /. 
              FreqGroup4 -> 
                group[1, 4]*Freqaa + group[2, 4]* FreqAa + 
                  group[3, 4]* FreqAA /. ρ -> 
              aveρ];

Δθ = 
      Factor[(θ /.  
              aveρ ->  
                aveρ + Δρ) - (θ)]

(Except for the factor, O Δρ, which is pulled into the θ and Rarity terms in this formulation, the above is identical to θ in the standard model.)

Note that assortment has twice the effect on \(D\_{AM, MM, AF}\) in this variant model.  When assortment happens within a group and aveρ is small, then males that are in the group are also likely to carry the modifier, doubling the chance that the modifier becomes associated with homozygosity.

\(\(\(\(-\(1\/2\)\)\ cf\ O\^2\ Δρ\ \((1 - 
                P\_M)\)\ P\_M - 
          2 \((\ \(c\/2\) 
                O\ Δrarity\ \ \((1 - P\_M)\)\ P\_M\ )\) + 
          O\^2\ \(D\_{AM, MM, AF}\) \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
                S\_AA[P\_A])\) /. subQLE;\)\(
\)
    \)\)
% - finalΔ(Subscript[P2, M]) // Factor

-(cf/2) (O^2) Δρ  (1 - 
              (Subscript[P, M])) (Subscript[P, M])  - 
        2 ( (c/2) 
              O Δrarity  (1 - (Subscript[P, M])) (Subscript[P, M]) )  + 
        2 ( (1/2) O Δ(θ/2)  (1 - 
                  (Subscript[P, M])) (Subscript[P, M]) ((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
                  (Subscript[S, AA])[(Subscript[P, A])]) );

    
% - finalΔ(Subscript[P2, M]) // Factor

PREFERENCE-BASED MODEL
-> With fixed and relative costs

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assume that assortative mating depends on the "A" (or i,k or m,o or q,s) locus which is also responsible for coevolution

The following preference matrix contains female preferences, with female genotypes at the A locus in rows and male genotypes in columns.

We assume that females have dislikes:
	* for males differing by no alleles (δ)  [allows for disassortative mating]
	* for males differing by one allele (κ).
	* for males differing by two alleles (ρ).

Such dislikes cause a reduction in female fitness (a direct cost of mate choice).

MatrixForm[
      MateMat = {{1 - O *δ, 1 - O *κ, 
            1 - O *ρ}, {1 - O *κ, 1 - O *δ, 
            1 - O *κ}, {1 - O *ρ, 1 - O*κ, 
            1 - O *δ}}]

Only the female's modifier status affects the strength of preference:

ModMat = {{δ -> (Subscript[δ, mm]), κ -> (Subscript[κ, mm]), ρ -> (Subscript[ρ, mm])}, {δ -> (Subscript[δ, Mm]), ρ -> (Subscript[ρ, Mm]), κ -> (Subscript[κ, Mm])}, {δ -> (Subscript[δ, MM]), κ -> (Subscript[κ, MM]), ρ -> (Subscript[ρ, MM])}};

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Define fitness of mated pairs

In the function below, female genome is given by {m,n,o,p} and male genome by {q,r,s,t} where letters take values 0 or 1 depending on allelic status at that position in the genome.

WMate[m_, n_, o_, p_, q_, r_, s_, t_] := 
        MateMat[[m + o + 1, q + s + 1]] /. 
          ModMat[[n + p + 1]];

Normalize WMate so that all females are mated

\(For[m = 1, 
      m ≤ 2, \(m++\), 
For[n = 1, 
        n ≤ 2, \(n++\), 
For[o = 1, 
          o ≤ 2, \(o++\), 
For[p = 1, 
            p ≤ 2, \(p++\), 
            NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 0]]]]\)

\(\(\(
\)\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 
                        NormalFemale\_{m - 1, n - 1, o - 1, p - 1} + 
                          X\_{q - 1, r - 1, s - 1, t - 1}' 
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]]]]]]]]];\)\(
\)
    \)\)\)

Here we add a relative cost of assortative mating, c, which decreases fitness in proportion to the average degree of dislikes exhibited.  Specifically, a female of genotype {m-1,n-1,o-1,p-1} will mate with a male of genotype {q-1,r-1,s-1,t-1} with probability WMate[m-1,n-1,o-1,p-1,q-1,r-1,s-1,t-1].  With probability O*c, her mating attempt cannot be recouped and so her fitness is WMate (reduced below 1 to the extent that she has dislikes).  With probability (1-O*c), she can recoup her mating attempt if she rejects the male and so she is guaranteed to have a fitness of 1 (i.e., we normalize by her mean preference, NormalFemale).

Note that we assume here that c is small (of order O).  In the next section, we allow c to be large (e.g., 1 as in the plant model).

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, 
                          t - 1] = 
                        O*c*WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1] + \((1 - O*c)\)*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                                s - 1, t - 1]/
                              NormalFemale\_{m - 1, n - 1, o - 1, p - 1}]]]]]]]];\)\)

Calculate the mean fitness of the population

\(\(M\&_ = 0;\)\)
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      M\&_ = M\&_ + 
                          X\_{m - 1, n - 1, o - 1, p - 1}'*
                            X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]]]]]]]]];\)\)
\(\(M\&_ = Collect[M\&_, c, Factor];\)\)

Calculate frequencies of mated pairs

Here we add a fixed cost of assortative mating, cf, which always decreases in females who non-randomly mate at higher rates:

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*δ + O*κ + O*ρ)\)*\((O*cf)\))\) /. 
                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                            1]\)])\)
]]]];\)\)

meanfertility = 1 + Factor[meanfertility - 1];

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*δ + 
                                        O*κ + O*ρ)\)*\((O*
                                        cf)\))\) /. 
                              ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\)*
                          X\_{q - 1, r - 1, s - 1, t - 1}'*
                          WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]/\((meanfertility*
                                M\&_)\)]]]]]]]];\)\)

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), etc.} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm])), ( (Subscript[δ, Mm]) - (Subscript[δ, mm])) == 
              hδ*( (Subscript[δ, MM]) - (Subscript[δ, mm])), Δδ == ((Subscript[P, M]) ( (Subscript[δ, MM]) - (Subscript[δ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[δ, Mm]) - (Subscript[δ, mm]))), 
aveδ == ((Subscript[P, M]^2) (Subscript[δ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[δ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[δ, mm])), ( (Subscript[κ, Mm]) - (Subscript[κ, mm])) == 
              hκ*( (Subscript[κ, MM]) - (Subscript[κ, mm])), Δκ == ((Subscript[P, M]) ( (Subscript[κ, MM]) - (Subscript[κ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[κ, Mm]) - (Subscript[κ, mm]))), 
aveκ == ((Subscript[P, M]^2) (Subscript[κ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[κ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[κ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), (Subscript[δ, mm]), (Subscript[δ, Mm]), (Subscript[δ, MM]), (Subscript[κ, mm]), (Subscript[κ, Mm]), (Subscript[κ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do change the frequency of A in the preference-based model (Equation 15):

Collect[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans, {c, cf, aveρ, aveδ, aveκ}, 
      Factor]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) =  (1/2) 
          O (Subscript[P, A]) (1 - 
              (Subscript[P, A])) (- 
                  aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 2 (Subscript[P, A])) -  
              aveκ (((1 - 2 (Subscript[P, A])))^3) + 
              aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                    3 (Subscript[P, A]^2)));

    Factor[%% - Δ(Subscript[PR, A])]

In the text, we wish to consider strong costs as well as weak, which can be incorporated by removing the order of c:

Collect[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) - Δ(Subscript[PR, A]) /. SubDSmall) /. 
              c -> c/O, {O, 0, 1}]] /. subTrans, {aveρ, 
        aveδ, aveκ}, Factor]

This is just c*Δ(Subscript[PR, A]), so that overall change in the A allele due to sexual selection can be written as the above value of Δ(Subscript[PR, A])  times (1+c):

Factor[%/ Δ(Subscript[PR, A])]

Collect[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) - Δ(Subscript[PR, A]) /. SubDSmall) /. 
              cf -> cf/O, {O, 0, 1}]] /. subTrans, {aveρ, 
        aveδ, aveκ}, Factor]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the preference-based model either:

Δ(Subscript[PR, M]) = 
      Simplify[Normal[Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]] /. 
          subTrans]

To order (O^2), the costs of non-random mating do change the frequency of M, as do associations between the modifier and selected loci (because of sexual selection):

\(ΔPR2\_M = 
      O\^2\/2*Collect[\(D[\((P\_M' - P\_M /. SubDSmall)\), {O, 2}] /. 
              O -> 0\) /. subTrans, {c, cf, D\_{AM, AF}, D\_{MM, MF}, 
            D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
            D\_{AM, MM, AF, MF}}, Factor]\)

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both selection and mating) to order O, assuming costs are weak:

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                    (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
                (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]) + (1/2) 
            O (Subscript[P, A]) (1 - 
                (Subscript[P, A])) (- 
                    aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 
                      2 (Subscript[P, A])) -  aveκ (((1 - 2 (Subscript[P, A])))^3) + 
                aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                      3 (Subscript[P, A]^2)));

     Δ(Subscript[P, M]) = 0;

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

This can be rewritten in terms of Δ(Subscript[P, A]) and the degree of dominance induced by both natural and sexual selection ((Subscript[H, animal])), which is derived next.

The overall fitness of the genotypes (including sexual and natural selection is given by):

overallfit = {(Subscript[W, AA])[x_] -> 
            1 + (Subscript[S, AA])[x] - 
              1/2 ( (x^2) aveδ + 
                    2  x (1 - x) aveκ + (((1 - x))^2) 
                      aveρ), 
          (Subscript[W, Aa])[x_] -> 
            1 + (Subscript[S, Aa])[x] - 
              1/2 ( (x^2) aveκ + 
                    2  x (1 - x) aveδ + (((1 - x))^2) 
                      aveκ), 
          (Subscript[W, aa])[x_] -> 
            1 + (Subscript[S, aa])[x] - 
              1/2 ( (x^2) aveρ + 
                    2  x (1 - x) aveκ + (((1 - x))^2) 
                      aveδ)};

This allows us to write the fitness advantage of homozygotes as:

(Subscript[H, animal]) = 
      (Subscript[W, AA])[(Subscript[P, A])] - 2 (Subscript[W, Aa])[(Subscript[P, A])] + (Subscript[W, aa])[(Subscript[P, A])] /. overallfit // 
        Factor

(Subscript[H, animal]) is called (Subscript[H, tot]) in the text.  It can be decomposed into a component coming from natural selection (Subscript[H, ns]) and one coming from sexual selection (Subscript[H, ss])(Equation 18):

((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + (Subscript[S, AA])[(Subscript[P, A])]) - 
        1/2 ( (Subscript[P, A]^2) (aveδ - 2  aveκ + aveρ) + 
              2  (Subscript[P, A]) (1 - (Subscript[P, A])) (2  aveκ - 
                    2  aveδ) + (((1 - (Subscript[P, A])))^2) (aveρ - 
                    2  aveκ + 
                    aveδ));
% - (Subscript[H, animal]) // Factor

The modifier thus changes by an amount not related to costs plus an amount proportional to costs:

\(Collect[ΔP2\_M - \ \ O\ \(D\_{AM, MM, AF}\) 
          O\ H\_animal - 
        O \((D\_{AM, MF} + 
              D\_{AM, MM})\) ΔP\_A\/\(\((1 - P\_A)\)\ P\_A\), {c, cf}, Factor]\)

Hence we need to derive the QLE values for the THREE  association measures given above.

The following must equal zero at QLE:

\(eqn\_{AM, MM} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {O, c, cf, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                      1}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {O, c, cf, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - 
                      D\_{AM, MM, AF})\) /. SimpleSubs\) /. SubDSmall, O] /. 
            O -> 0\) /. subTrans, {O, c, cf, D\_{AM, AF}, D\_{MM, MF}, 
          D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

\(D\_{AM, MM, AF}\) can be written as:

(1 - 
            (Subscript[P, M])) (Subscript[P, M]) (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) ((Δρ - Δδ) (1 - 
                  (Subscript[P, A])) (Subscript[P, A]) + (Δκ - Δδ) (((1 - 2 (Subscript[P, A])))^2));

\(%/D\_{AM, MM, AF} /. subQLE // Factor\)

If interested in the average level of homozygosity at QLE:

\(eqn\_{AM, AF} = 
      Collect[\(D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen\) /. ChangeVars)\) - D\_{AM, AF})\) /. 
                  SimpleSubs\) /. SubDSmall, O] /. O -> 0\) /. 
          subTrans, {O, c, cf, \ D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

Adding together the change in \(\(\(\ \)\(D\_{AM, AF}\)\)\) due to natural selection and mating:

\(\(O\ \((\(-1\) + P\_A)\)\^2\ P\_A\%2\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
              S\_AA[P\_A])\) + O\ \((eqn\_{AM, AF})\);\)\)

which can be solved to give the QLE prediction for the departure from Hardy-Weinberg, \(\(\(\ \)\(D\_{AM, AF}\)\)\):

\(D\_{AM, AF} /. \((Solve[% == 0, D\_{AM, AF}] // Flatten)\) // 
      Simplify\)

finalΔ(Subscript[P2, M]) = 
      Factor[Δ(Subscript[P2, M]) /. subQLE /. subTrans]

which can be written using the following terms.   

The change caused by the modifier on \(D\_{AM, AF}\):

Dterm = -(((-1 + (Subscript[P, A])))^2) (Subscript[P, A]^2) (2 aveδ - 
                2 aveκ - 
                2 (3 aveδ - 4 aveκ + aveρ) (Subscript[P, A]) + 
                2 (3 aveδ - 4 aveκ + 
                      aveρ) (Subscript[P, A]^2) - (Subscript[S, aa])[(Subscript[P, A])] + 2 (Subscript[S, Aa])[(Subscript[P, A])] - 
                (Subscript[S, AA])[(Subscript[P, A])]) /. {aveδ -> δ, 
            aveκ -> κ, 
            aveρ -> ρ};
\(ΔD\_{AM, AF} = \((\((\(P\_M\) 
                      Dterm /. {δ -> δ\_MM, \ κ -> κ\_MM\ , ρ -> ρ\_MM\ })\) + \((\((1 - P\_M)\) 
                      Dterm /. {δ -> δ\_Mm, \ κ -> κ\_Mm\ , ρ -> ρ\_Mm\ })\))\) - \((\((\(P\_M\) 
                      Dterm /. {δ -> δ\_Mm, \ κ -> κ\_Mm\ , ρ -> ρ\_Mm\ })\) + \((\((1 - P\_M)\) 
                      Dterm /. {δ -> δ\_mm, \ κ -> κ\_mm\ , ρ -> ρ\_mm\ })\))\) /. subTrans // 
        Factor\)

which can be written as (Equation 20b):

2 (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) ((Δρ - Δδ) (1 - 
                  (Subscript[P, A])) (Subscript[P, A]) + (Δκ - Δδ) (((1 - 2 (Subscript[P, A])))^2));

\(Factor[% - ΔD\_{AM, AF}]\)

\(D\_{AM, MM, AF}\) is proportional to \(ΔD\_{AM, AF}\)(Equation 20a):

\(\(\(\(\((1 - P\_M)\)\ P\_M\)\/2\ ΔD\_{AM, AF};\)\(
\)
    \)\)
\(Factor[% - D\_{AM, MM, AF} /. subQLE]\)

The change caused by the modifier on Δ(Subscript[P, A]) (Equation 19b):

ΔPAterm = Δ(Subscript[P, A]) /. {aveδ -> δ, aveκ -> κ, 
            aveρ -> ρ};
Δψ = (((Subscript[P, M]) ΔPAterm /. {δ -> (Subscript[δ, MM]),  κ -> (Subscript[κ, MM]) , ρ -> (Subscript[ρ, MM]) }) + ((1 - 
                          (Subscript[P, M])) ΔPAterm /. {δ -> (Subscript[δ, Mm]),  κ -> (Subscript[κ, Mm]) , ρ -> (Subscript[ρ, Mm]) })) - (((Subscript[P, M]) ΔPAterm /. {δ -> (Subscript[δ, Mm]),  κ -> (Subscript[κ, Mm]) , ρ -> (Subscript[ρ, Mm]) }) + ((1 - 
                          (Subscript[P, M])) ΔPAterm /. {δ -> (Subscript[δ, mm]),  κ -> (Subscript[κ, mm]) , ρ -> (Subscript[ρ, mm]) })) /. 
          subTrans // Factor

The relative costs depend on the change in pickiness of the females:

ChangeInPickiness =   O (Δδ*
                        mate0 + Δκ*
                        mate1 + Δρ*mate2) /. 
                mate0 -> (((1 - (Subscript[P, A])))^4)  + (((2 (1 - (Subscript[P, A])) (Subscript[P, A])))^2) + (Subscript[P, A]^4) /. 
              mate1 -> 4 (1 - (Subscript[P, A])) (Subscript[P, A]) ((((1 - (Subscript[P, A])))^2)  + 
                      (Subscript[P, A]^2)) /. mate2 -> 2 (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) // 
          Factor;

Note that 2 (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) is the probability that opposite homozygotes would have mated while 4 (1 - (Subscript[P, A])) (Subscript[P, A]) ((((1 - (Subscript[P, A])))^2)  + (Subscript[P, A]^2)) is the probability that matings would have occured with males that differ by one allele.

Altogether, the change in the modifier can be written as (Equation 17):

\(O\^2\ H\_animal\ D\_{AM, MM, AF}\)+\(\(\(\(ΔP\_A\)\(\ \)\)\/\(\((1 - 
                      P\_A)\)\ P\_A\)\) \((O\ \ D\_{AM, MM} + 
                O\ \ D\_{AM, MF})\)\) -(1/2) cf (O^2) (Δρ + Δδ + Δκ) (1 - (Subscript[P, M])) (Subscript[P, M])-(1/2) O c ChangeInPickiness (1 - (Subscript[P, M])) (Subscript[P, M])/.subQLE;
Factor[% - finalΔ(Subscript[P2, M])]

(1/2)(O^2) (1 - (Subscript[P, M])) (Subscript[P, M])\(ΔD\_{AM, AF}\) (Subscript[H, animal]) +\(\(\(\(ΔP\_A\)\(\ \)\)\/\(\((1 - 
                      P\_A)\)\ P\_A\)\) \((O\ \ D\_{AM, MM} + 
                O\ \ D\_{AM, MF})\)\) -(1/2) cf (O^2) (Δδ + Δκ + Δρ) (1 - (Subscript[P, M])) (Subscript[P, M])-(1/2) O c ChangeInPickiness (1 - (Subscript[P, M])) (Subscript[P, M])/.subQLE;
Factor[% - finalΔ(Subscript[P2, M])]

\(\(1\/2\) \(O\^2\) \((1 - 
                P\_M)\)\ \(P\_M\) ΔD\_{AM, AF}\ H\_animal\) +((Δ(Subscript[P, A]) )/((1 - 
                      (Subscript[P, A])) (Subscript[P, A]))) 
            2 (1 - (Subscript[P, M])) (Subscript[P, M]) (Δψ) -(1/2) cf (O^2) (Δδ + Δκ + Δρ) (1 - (Subscript[P, M])) (Subscript[P, M])-(1/2) O c ChangeInPickiness (1 - (Subscript[P, M])) (Subscript[P, M])/.subQLE;
Factor[% - 
        finalΔ(Subscript[P2, M])]

ESS (no costs)

In this package, we assume weak selection, so that the departure from Hardy-Weinberg is negligible.  See FreqDepSexSel.nb for a one-locus stability analysis that does not assume weak selection.

General

The overall fitness of the genotypes (including sexual and natural selection is given by):

overallfit = {(Subscript[W, AA])[x_] -> 
            1 + (Subscript[S, AA])[x] - 
              1/2 ( (x^2) aveδ + 
                    2  x (1 - x) aveκ + (((1 - x))^2) 
                      aveρ), 
          (Subscript[W, Aa])[x_] -> 
            1 + (Subscript[S, Aa])[x] - 
              1/2 ( (x^2) aveκ + 
                    2  x (1 - x) aveδ + (((1 - x))^2) 
                      aveκ), 
          (Subscript[W, aa])[x_] -> 
            1 + (Subscript[S, aa])[x] - 
              1/2 ( (x^2) aveρ + 
                    2  x (1 - x) aveκ + (((1 - x))^2) 
                      aveδ)};

This allows us to write the fitness advantage of homozygotes as:

(Subscript[H, animal]) = 
      (Subscript[W, AA])[(Subscript[P, A])] - 2 (Subscript[W, Aa])[(Subscript[P, A])] + (Subscript[W, aa])[(Subscript[P, A])] /. overallfit // 
        Factor

At the ESS, if one exists, (Subscript[H, animal])will equal zero (note that (Subscript[P, A]) must be constant at an ESS).  That is, \(W\_aa[p\&^] - 2\ W\_Aa[p\&^] + W\_AA[p\&^]\) = 0, where fitness includes both sexual and natural selection.

\(\(\((W\_aa[p\&^] - 2\ W\_Aa[p\&^] + W\_AA[p\&^])\) /. overallfit\) /. 
        P\_A -> p\&^ // Factor\)

If the heterozygote's fitness is the average of the homozygotes' fitnesses, then the equilibrium condition for \(p\&^\) will allow a polymorphic equilibrium only if \(W\_aa[p\&^] = W\_AA[p\&^]\).  That is, at a polymorphic ESS equilibrium, all fitnesses must be equal.
This can be shown be first demonstrating that  Δ(Subscript[P, A]) can be written as:

O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) ((1 - (Subscript[P, A])) ( 
                  (Subscript[W, Aa])[(Subscript[P, A])] - (Subscript[W, aa])[(Subscript[P, A])]) + 
              (Subscript[P, A]) ((Subscript[W, AA])[(Subscript[P, A])] - (Subscript[W, Aa])[(Subscript[P, A])])) /. 
        overallfit;
Factor[%/ Δ(Subscript[P, A])]

And then noting that Δ(Subscript[P, A]) will equal zero at a point other than 0 or 1 only if the following equals zero at some internal point:

((1 - (Subscript[P, A])) ( (Subscript[W, Aa])[(Subscript[P, A])] - (Subscript[W, aa])[(Subscript[P, A])]) + 
            (Subscript[P, A]) ((Subscript[W, AA])[(Subscript[P, A])] - (Subscript[W, Aa])[(Subscript[P, A])])) /.  
        (Subscript[W, Aa])[(Subscript[P, A])] -> ((Subscript[W, AA])[(Subscript[P, A])] + (Subscript[W, aa])[(Subscript[P, A])])/2 // 
      Factor

When (Subscript[P, A])=1/2, the ESS is expected to equal:

Solve[((Subscript[H, animal]) /. (Subscript[P, A]) -> 1/2) == 0, 
      aveρ]

this equals 4 (Subscript[H, ns]) when there is no dissartative mating (Equation 21).

The ESS when aveκ=0

ESSκ0 = 
      aveρ /. 
        Flatten[Solve[((Subscript[H, animal]) /. aveδ -> 0 /. 
                  aveκ -> 0) == 0, 
            aveρ]]
ESSκ0b = %/((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + (Subscript[S, AA])[(Subscript[P, A])]) // 
        Factor

The ESS when aveκ=aveρ/2

ESSκρ2 = 
      aveρ /. 
        Flatten[Solve[((Subscript[H, animal]) /. aveδ -> 0 /. 
                  aveκ -> aveρ/2) == 0, 
            aveρ]]
ESSκρ2b = %/((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[S, AA])[(Subscript[P, A])]) // Factor

The ESS when aveκ=aveρ

ESSκρ = 
      aveρ /. 
        Flatten[Solve[((Subscript[H, animal]) /. aveδ -> 0 /. 
                  aveκ -> aveρ) == 0, 
            aveρ]]
ESSκρb = %/((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[S, AA])[(Subscript[P, A])]) // Factor

DisplayTogether[
Plot[ESSκ0b, {(Subscript[P, A]), 0, 1}, 
        PlotStyle -> Dashing[{0.04}]], 
Plot[
        ESSκρ2b, {(Subscript[P, A]), 0, 1}, 
        PlotStyle -> Dashing[{0.01}]], 
Plot[
        ESSκρb, {(Subscript[P, A]), 0, 
          1}], 
PlotRange -> {Automatic, {0, 
            25}}
]

Export["Fig.eps", %];

The problem with this figure is that as assortative mating evolves, the allele frequencies will change (away from 1/2 because of the positive frequency-dependent selection induced).

The ESS when 1-aveκ=1-v and 1-aveρ = (((1 - v))^4) (as considered by Matessi et al) - focusing only on (Subscript[P, A]) = 1/2

(Expand[
                    (Subscript[H, animal])] /. ((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
                        (Subscript[S, AA])[(Subscript[P, A])]) -> H /. 
                aveδ -> 0 /. aveκ -> v/.aveρ->1-(((1 - v))^4)/.(Subscript[P, A]) -> 1/2)//Factor

ESSv = v /. Flatten[Solve[% == 0, v]]
Normal[Series[%, {H, 0, 1}]]
ESSvb = %/H /. (Subscript[P, A]) -> 1/2 // Factor

Note that in Matessi's model, ((Subscript[S, aa])[(1/2)] - 2 (Subscript[S, Aa])[(1/2)] + (Subscript[S, AA])[(1/2)]) equals 2  α, so we recover the fact that the ESS occurs at v = 2α [p. 54]

MatessiFit[y_, x_] = 
        1 + α y^2  -  (α + β) x y  +  β (x^2 + s^2);

MatessiFit[-1, 0] - 2 MatessiFit[0, 0] + MatessiFit[1, 0] // 
      Factor

Case 1: aveκ = aveρ

subcase = {aveδ -> 0, aveκ -> ESSκρ, 
          aveρ -> ESSκρ};
parset = {(Subscript[b, Aa]) -> 0, (Subscript[b, AA]) -> -(Subscript[b, aa]), (Subscript[a, AA]) -> 0, 
          (Subscript[a, Aa]) -> -2/3 1/10, 
          (Subscript[a, aa]) -> -1/10};

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                    (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
                (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]) + (1/2) 
            O (Subscript[P, A]) (1 - 
                (Subscript[P, A])) (- 
                    aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 
                      2 (Subscript[P, A])) -  aveκ (((1 - 2 (Subscript[P, A])))^3) + 
                aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                      3 (Subscript[P, A]^2)));

(Subscript[essP, A]) =  Δ(Subscript[P, A])/((1 - (Subscript[P, A])) (Subscript[P, A])) /. 
                subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) // 
        Factor

Solving the above for (Subscript[b, aa]) for a particular parameter set:

Factor[
      (Subscript[b, aa]) /. Flatten[
          Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[b, aa])]]]

There are some values of (Subscript[b, aa]) (y-axis) that are consistent with an underdominant polymorphism and that yield a value of (Subscript[P, A]) (x-axis) between zero and one:

DisplayTogether[
Plot[
        ESSκρb/20, {(Subscript[P, A]), 0, 1}, 
        PlotStyle -> 
          Dashing[{0.01}]], 
Plot[((2 - 10 (Subscript[P, A]) + 9 (Subscript[P, A]^2))/(30 (-1 + 2 (Subscript[P, A])) (1 - 6 (Subscript[P, A]) + 6 (Subscript[P, A]^2)))), {(Subscript[P, A]), 0, 1}, 
        PlotStyle -> 
          Thickness[
            0.005]], 
PlotRange -> {Automatic, {2/3 1/
                10, 1}}
]

DisplayTogether[
Plot[
        ESSκρb/20, {(Subscript[P, A]), 0.5, 1}, 
        PlotStyle -> 
          Dashing[{0.01}]], 
Plot[((2 - 10 (Subscript[P, A]) + 9 (Subscript[P, A]^2))/(30 (-1 + 2 (Subscript[P, A])) (1 - 6 (Subscript[P, A]) + 6 (Subscript[P, A]^2)))), {(Subscript[P, A]), 0.5, 1}, 
        PlotStyle -> 
          Thickness[
            0.005]], 
PlotRange -> {Automatic, {2/3 1/
                10, 1}}
]

NSolve[
      D[((2 - 10 (Subscript[P, A]) + 9 (Subscript[P, A]^2))/(30 (-1 + 2 (Subscript[P, A])) (1 - 6 (Subscript[P, A]) + 6 (Subscript[P, A]^2)))), (Subscript[P, A])] == 0, (Subscript[P, A])]

((2 - 10 (Subscript[P, A]) + 9 (Subscript[P, A]^2))/(30 (-1 + 2 (Subscript[P, A])) (1 - 6 (Subscript[P, A]) + 6 (Subscript[P, A]^2)))) /. %

...This suggests that (Subscript[b, aa]) must be greater than about 0.19 in order for the equilibrium to persist at an ESS for assortative mating.  Note that this cannot be determined from the stability of the edges, because the ESS level of assortative mating at (Subscript[P, A])= 0 or 1 is a negative number.

NSolve[1 - 6 (Subscript[P, A]) + 6 (Subscript[P, A]^2) == 0, (Subscript[P, A])]

aveκ /. subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) /. 
        parset /. (Subscript[P, A]) -> 1

(Subscript[S, Aa])[(Subscript[P, A])] - (Subscript[S, AA])[(Subscript[P, A])] - aveκ /. subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) /. 
        parset /. (Subscript[P, A]) -> 1

(Subscript[S, Aa])[(Subscript[P, A])] - (Subscript[S, aa])[(Subscript[P, A])] - aveκ /. subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) /. 
        parset /. (Subscript[P, A]) -> 0

Consider the case where (Subscript[b, aa]) = 3/10.  Without sexual selection the equilibrium would be:

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
          parset /. (Subscript[b, aa]) -> 3/10 // N

With sexual selection the equilibrium would be one of:

PossibleEquil = 
      Sort[Simplify[
          ComplexExpand[
            (Subscript[P, A]) /. Solve[
                Factor[(Subscript[essP, A]) /. parset /. (Subscript[b, aa]) -> 3/10] == 
                  0, (Subscript[P, A])]]]]

% // N

The following must be negative for the equilibrium to be stable, assuming weak selection and negligible disequilibrium (see one-locus package entitled FreqDepSexSel.nb):

(-((Subscript[W, aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, aa]))'[\(p\&^\)]+((Subscript[W, Aa]))'[\(p\&^\)]-2 \(p\&^\) ((Subscript[W, Aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, AA]))'[\(p\&^\)])/.((Subscript[W, AA]))'[x_]->2 (Subscript[b, AA]) - aveκ + 
                                      aveρ - aveδ x + 
                                      2 aveκ x - aveρ x/.((Subscript[W, Aa]))'[x_]->2 (Subscript[b, Aa]) - aveδ + 
                                    aveκ + 2 aveδ x - 
                                    2 aveκ x/.((Subscript[W, aa]))'[x_]->2 (Subscript[b, aa]) + aveδ - 
                                  aveκ - aveδ x + 
                                  2 aveκ x - aveρ x/.(Subscript[W, AA])[x_] -> 
                              1 + (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) + 
                                1/2 ( (x^2) (1 - aveδ) + 
                                      2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - aveρ))/.(Subscript[W, Aa])[x_] -> 
                            1 + (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) + 
                              1/2 ( (x^2) (1 - aveκ) + 
                                    2  x (1 - x) (1 - 
                                        aveδ) + (((1 - 
                                        x))^2) (1 - 
                                        aveκ))/.(Subscript[W, aa])[x_] -> 
                          1 + (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) + 
                            1/2 ( (x^2) (1 - aveρ) + 
                                  2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - 
                                        aveδ))/.subcase/.\(P\_A -> p\&^\)/.(Subscript[S, AA])[x_] -> 
                    (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x))/.(Subscript[S, Aa])[x_] -> 
                  (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x))/.(Subscript[S, aa])[x_] -> 
                (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x))/.parset/.(Subscript[b, aa]) -> 3/10/.\(p\&^ -> PossibleEquil\)//N

Thus, the only equilibrium that is stable in this case is the one at \(p\&^\) = 0.595202

tab = 
      Table[Sort[
            Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

Dropping the case where frequency-dependent selection is too weak ((Subscript[b, aa]) = 0.1):

Table[
          Sort[Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 2/10, 1, 1/10}] // 
        N;
withsexsel1 = 
      Transpose[{Transpose[%][[2]], 
          ESSκρb /. 
            (Subscript[P, A]) -> Transpose[%][[2]]}]

basepoly = 
      Table[{(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. parset, 0}, {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
        parset /. (Subscript[b, aa]) -> 2/3 1/10

plot1 = 
      DisplayTogether[
Plot[ESSκ0b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.04}]], 
Plot[
          ESSκρ2b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.01}]], 
Plot[
          ESSκρb, {(Subscript[P, A]), 0, 1}], 
ListPlot[
          withsexsel1, 
          PlotStyle -> PointSize[0.02]], 
ListPlot[
          basepoly, 
          PlotStyle -> 
            PointSize[
              0.02]], 
PlotRange -> {Automatic, {-0.5, 25}}
]

Case 2: aveκ = aveρ/2

subcase = {aveδ -> 0, 
          aveκ -> ESSκρ2/2, 
          aveρ -> ESSκρ2};
parset = {(Subscript[b, Aa]) -> 0, (Subscript[b, AA]) -> -(Subscript[b, aa]), (Subscript[a, AA]) -> 0, 
          (Subscript[a, Aa]) -> -2/3 1/10, 
          (Subscript[a, aa]) -> -1/10};

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                    (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
                (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]) + (1/2) 
            O (Subscript[P, A]) (1 - 
                (Subscript[P, A])) (- 
                    aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 
                      2 (Subscript[P, A])) -  aveκ (((1 - 2 (Subscript[P, A])))^3) + 
                aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                      3 (Subscript[P, A]^2)));

(Subscript[essP, A]) =  Δ(Subscript[P, A])/((1 - (Subscript[P, A])) (Subscript[P, A])) /. 
                subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) // 
        Factor

Solving the above for (Subscript[b, aa]) for a particular parameter set:

Factor[
      (Subscript[b, aa]) /. Flatten[
          Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[b, aa])]]]

There are some values of (Subscript[b, aa]) (y-axis) that are consistent with an underdominant polymorphism and that yield a value of (Subscript[P, A]) (x-axis) between zero and one:

DisplayTogether[
Plot[
        ESSκρ2b/20, {(Subscript[P, A]), 0, 
          1}], 
Plot[%, {(Subscript[P, A]), 0, 1}, 
        PlotStyle -> 
          Thickness[
            0.005]], 
PlotRange -> {Automatic, {2/3 1/
                10, 1}}
]

NSolve[
      D[((1 - 8 (Subscript[P, A]) + 6 (Subscript[P, A]^2))/(120 (-1 + (Subscript[P, A])) (Subscript[P, A]) (-1 + 2 (Subscript[P, A])))), (Subscript[P, A])] == 0, (Subscript[P, A])]

((1 - 8 (Subscript[P, A]) + 6 (Subscript[P, A]^2))/(120 (-1 + (Subscript[P, A])) (Subscript[P, A]) (-1 + 2 (Subscript[P, A])))) /. %

...This suggests that (Subscript[b, aa]) must be greater than about 0.134 in order for the equilibrium to persist at an ESS for assortative mating.  Note that this cannot be determined from the stability of the edges, because the ESS level of assortative mating at (Subscript[P, A])= 0 or 1 is a negative number.

aveκ /. subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) /. 
        parset /. (Subscript[P, A]) -> 1

Consider the case where (Subscript[b, aa]) = 3/10.  Without sexual selection the equilibrium would be:

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
          parset /. (Subscript[b, aa]) -> 3/10 // N

With sexual selection the equilibrium would be one of:

PossibleEquil = 
      Sort[Simplify[
          ComplexExpand[
            (Subscript[P, A]) /. Solve[
                Factor[(Subscript[essP, A]) /. parset /. (Subscript[b, aa]) -> 3/10] == 
                  0, (Subscript[P, A])]]]]

% // N

The following must be positive for the equilibrium to be stable (see one-locus package entitled FreqDepSexSel.nb):

(-((Subscript[W, aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, aa]))'[\(p\&^\)]+((Subscript[W, Aa]))'[\(p\&^\)]-2 \(p\&^\) ((Subscript[W, Aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, AA]))'[\(p\&^\)])/.((Subscript[W, AA]))'[x_]->2 (Subscript[b, AA]) - aveκ + 
                                      aveρ - aveδ x + 
                                      2 aveκ x - aveρ x/.((Subscript[W, Aa]))'[x_]->2 (Subscript[b, Aa]) - aveδ + 
                                    aveκ + 2 aveδ x - 
                                    2 aveκ x/.((Subscript[W, aa]))'[x_]->2 (Subscript[b, aa]) + aveδ - 
                                  aveκ - aveδ x + 
                                  2 aveκ x - aveρ x/.(Subscript[W, AA])[x_] -> 
                              1 + (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) + 
                                1/2 ( (x^2) (1 - aveδ) + 
                                      2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - aveρ))/.(Subscript[W, Aa])[x_] -> 
                            1 + (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) + 
                              1/2 ( (x^2) (1 - aveκ) + 
                                    2  x (1 - x) (1 - 
                                        aveδ) + (((1 - 
                                        x))^2) (1 - 
                                        aveκ))/.(Subscript[W, aa])[x_] -> 
                          1 + (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) + 
                            1/2 ( (x^2) (1 - aveρ) + 
                                  2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - 
                                        aveδ))/.subcase/.\(P\_A -> p\&^\)/.(Subscript[S, AA])[x_] -> 
                    (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x))/.(Subscript[S, Aa])[x_] -> 
                  (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x))/.(Subscript[S, aa])[x_] -> 
                (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x))/.parset/.(Subscript[b, aa]) -> 3/10/.\(p\&^ -> PossibleEquil\)//N

Thus, the only equilibrium that is stable in this case is the one at \(p\&^\) = 0.595202

tab = 
      Table[Sort[
            Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

Dropping the case where frequency-dependent selection is too weak ((Subscript[b, aa]) = 0.1):

Table[
          Sort[Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 2/10, 1, 1/10}] // 
        N;
withsexsel1 = 
      Transpose[{Transpose[%][[2]], 
          ESSκρ2b /. 
            (Subscript[P, A]) -> Transpose[%][[2]]}]

basepoly = 
      Table[{(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. parset, 0}, {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
        parset /. (Subscript[b, aa]) -> 2/3 1/10

plot2 = 
      DisplayTogether[
Plot[ESSκ0b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.04}]], 
Plot[
          ESSκρ2b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.01}]], 
Plot[
          ESSκρb, {(Subscript[P, A]), 0, 1}], 
ListPlot[
          withsexsel1, 
          PlotStyle -> PointSize[0.02]], 
ListPlot[
          basepoly, 
          PlotStyle -> 
            PointSize[
              0.02]], 
PlotRange -> {Automatic, {-0.5, 25}}
]

Case 3: aveκ = 0

subcase = {aveδ -> 0, aveκ -> ESSκ0/2, 
          aveρ -> ESSκ0};
parset = {(Subscript[b, Aa]) -> 0, (Subscript[b, AA]) -> -(Subscript[b, aa]), (Subscript[a, AA]) -> 0, 
          (Subscript[a, Aa]) -> -2/3 1/10, 
          (Subscript[a, aa]) -> -1/10};

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                    (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
                (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]) + (1/2) 
            O (Subscript[P, A]) (1 - 
                (Subscript[P, A])) (- 
                    aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 
                      2 (Subscript[P, A])) -  aveκ (((1 - 2 (Subscript[P, A])))^3) + 
                aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                      3 (Subscript[P, A]^2)));

(Subscript[essP, A]) =  Δ(Subscript[P, A])/((1 - (Subscript[P, A])) (Subscript[P, A])) /. 
                subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) // 
        Factor

Solving the above for (Subscript[b, aa]) for a particular parameter set:

Factor[
      (Subscript[b, aa]) /. Flatten[
          Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[b, aa])]]]

There are some values of (Subscript[b, aa]) (y-axis) that are consistent with an underdominant polymorphism and that yield a value of (Subscript[P, A]) (x-axis) between zero and one:

DisplayTogether[
Plot[
        ESSκ0b/10, {(Subscript[P, A]), 0, 1}], 
Plot[%, {(Subscript[P, A]), 0, 
          1}, PlotStyle -> 
          Thickness[
            0.005]], 
PlotRange -> {Automatic, {2/3 1/
                10, 1}}
]

((1 + 4 (Subscript[P, A]))/(60 (-1 + 2 (Subscript[P, A])))) /. 
      (Subscript[P, A]) -> 1

% // N

...This suggests that (Subscript[b, aa]) must be greater than about 0.083 in order for the equilibrium to persist at an ESS for assortative mating.

aveκ /. subcase /. 
              (Subscript[S, AA])[x_] -> (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) /. 
            (Subscript[S, Aa])[x_] -> (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) /. 
          (Subscript[S, aa])[x_] -> (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) /. 
        parset /. (Subscript[P, A]) -> 1

Consider the case where (Subscript[b, aa]) = 3/10.  Without sexual selection the equilibrium would be:

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
          parset /. (Subscript[b, aa]) -> 3/10 // N

With sexual selection the equilibrium would be one of:

PossibleEquil = 
      Sort[Simplify[
          ComplexExpand[
            (Subscript[P, A]) /. Solve[
                Factor[(Subscript[essP, A]) /. parset /. (Subscript[b, aa]) -> 3/10] == 
                  0, (Subscript[P, A])]]]]

% // N

The following must be positive for the equilibrium to be stable (see one-locus package entitled FreqDepSexSel.nb):

(-((Subscript[W, aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, aa]))'[\(p\&^\)]+((Subscript[W, Aa]))'[\(p\&^\)]-2 \(p\&^\) ((Subscript[W, Aa]))'[\(p\&^\)]+\(p\&^\) ((Subscript[W, AA]))'[\(p\&^\)])/.((Subscript[W, AA]))'[x_]->2 (Subscript[b, AA]) - aveκ + 
                                      aveρ - aveδ x + 
                                      2 aveκ x - aveρ x/.((Subscript[W, Aa]))'[x_]->2 (Subscript[b, Aa]) - aveδ + 
                                    aveκ + 2 aveδ x - 
                                    2 aveκ x/.((Subscript[W, aa]))'[x_]->2 (Subscript[b, aa]) + aveδ - 
                                  aveκ - aveδ x + 
                                  2 aveκ x - aveρ x/.(Subscript[W, AA])[x_] -> 
                              1 + (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x)) + 
                                1/2 ( (x^2) (1 - aveδ) + 
                                      2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - aveρ))/.(Subscript[W, Aa])[x_] -> 
                            1 + (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x)) + 
                              1/2 ( (x^2) (1 - aveκ) + 
                                    2  x (1 - x) (1 - 
                                        aveδ) + (((1 - 
                                        x))^2) (1 - 
                                        aveκ))/.(Subscript[W, aa])[x_] -> 
                          1 + (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x)) + 
                            1/2 ( (x^2) (1 - aveρ) + 
                                  2  x (1 - x) (1 - 
                                        aveκ) + (((1 - 
                                        x))^2) (1 - 
                                        aveδ))/.subcase/.\(P\_A -> p\&^\)/.(Subscript[S, AA])[x_] -> 
                    (Subscript[a, AA]) + (Subscript[b, AA]) (x - (1 - x))/.(Subscript[S, Aa])[x_] -> 
                  (Subscript[a, Aa]) + (Subscript[b, Aa]) (x - (1 - x))/.(Subscript[S, aa])[x_] -> 
                (Subscript[a, aa]) + (Subscript[b, aa]) (x - (1 - x))/.parset/.(Subscript[b, aa]) -> 3/10/.\(p\&^ -> PossibleEquil\)//N

Thus, the only equilibrium that is stable in this case is the single polymorphic one.

tab = 
      Table[Sort[
            Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

Dropping the case where frequency-dependent selection is too weak ((Subscript[b, aa]) = 0.1):

Table[
          Sort[Simplify[
              ComplexExpand[
                (Subscript[P, A]) /. Solve[Factor[(Subscript[essP, A]) /. parset] == 0, (Subscript[P, A])]]], 
            Abs[#1] < Abs[#2] &], {(Subscript[b, aa]), 1/10, 1, 1/10}] // 
        N;
withsexsel1 = 
      Transpose[{Transpose[%][[1]], 
          ESSκ0b /. (Subscript[P, A]) -> Transpose[%][[1]]}]

basepoly = 
      Table[{(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. parset, 0}, {(Subscript[b, aa]), 1/10, 1, 1/10}] // N

(((Subscript[a, Aa]) - (Subscript[a, aa]) + (Subscript[b, aa]))/(2 (Subscript[a, Aa]) - (Subscript[a, aa]) - (Subscript[a, AA]) + 2 (Subscript[b, aa]))) /. 
        parset /. (Subscript[b, aa]) -> 2/3 1/10

plot3 = 
      DisplayTogether[
Plot[ESSκ0b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.04}]], 
Plot[
          ESSκρ2b, {(Subscript[P, A]), 0, 1}, 
          PlotStyle -> Dashing[{0.01}]], 
Plot[
          ESSκρb, {(Subscript[P, A]), 0, 1}], 
ListPlot[
          withsexsel1, 
          PlotStyle -> PointSize[0.02]], 
ListPlot[
          basepoly, 
          PlotStyle -> 
            PointSize[
              0.02]], 
PlotRange -> {Automatic, {-0.5, 25}}
]

Joining the three plots

Show[plot1, plot2, plot3]

Export["Fig.eps", %];

PREFERENCE-BASED MODEL
-> Allowing strong costs

Strong costs are of special interest in the preference-based model, because the plant model (with relative costs = 1) has been used so extensively in the past.  In this section, we allow costs to be strong and determine the leading order terms in the change in allele frequencies.  This allows us to present the results in the text in such a way that they are accurate when costs are weak (previous section) or when they are strong (this section).  In either case, we present results that are to leading order only.  Specifically, in Equation (17), if costs are strong, the first line is of order O and the second line and all other (O^2) terms must be neglected.  Thus, although strong costs would also enter into the association measures (e.g., 19b), the association measures are only relevant to the modifier if costs are weak, in which case the costs drop out of the association measures to leading order.

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assume that assortative mating depends on the "A" (or i,k or m,o or q,s) locus which is also responsible for coevolution

The following preference matrix contains female preferences, with female genotypes at the A locus in rows and male genotypes in columns.

We assume that females have dislikes:
	* for males differing by no alleles (δ)  [allows for disassortative mating]
	* for males differing by one allele (κ).
	* for males differing by two alleles (ρ).

Such dislikes cause a reduction in female fitness (a direct cost of mate choice).

MatrixForm[
      MateMat = {{1 - O *δ, 1 - O *κ, 
            1 - O *ρ}, {1 - O *κ, 1 - O *δ, 
            1 - O *κ}, {1 - O *ρ, 1 - O*κ, 
            1 - O *δ}}]

Only the female's modifier status affect the strength of preference:

ModMat = {{δ -> (Subscript[δ, mm]), κ -> (Subscript[κ, mm]), ρ -> (Subscript[ρ, mm])}, {δ -> (Subscript[δ, Mm]), ρ -> (Subscript[ρ, Mm]), κ -> (Subscript[κ, Mm])}, {δ -> (Subscript[δ, MM]), κ -> (Subscript[κ, MM]), ρ -> (Subscript[ρ, MM])}};

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Define fitness of mated pairs

In the function below, female genome is given by {m,n,o,p} and male genome by {q,r,s,t} where letters take values 0 or 1 dpending on allelic status at that position in the genome.

WMate[m_, n_, o_, p_, q_, r_, s_, t_] := 
        MateMat[[m + o + 1, q + s + 1]] /. 
          ModMat[[n + p + 1]];

Normalize WMate so that all females are mated

\(For[m = 1, 
      m ≤ 2, \(m++\), 
For[n = 1, 
        n ≤ 2, \(n++\), 
For[o = 1, 
          o ≤ 2, \(o++\), 
For[p = 1, 
            p ≤ 2, \(p++\), 
            NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 0]]]]\)

\(\(\(
\)\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 
                        NormalFemale\_{m - 1, n - 1, o - 1, p - 1} + 
                          X\_{q - 1, r - 1, s - 1, t - 1}' 
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]]]]]]]]];\)\(
\)
    \)\)\)

Here we add a relative cost of assortative mating, c, which decreases fitness in proportion to the average degree of dislikes exhibited.  Specifically, a female of genotype {m-1,n-1,o-1,p-1} will mate with a male of genotype {q-1,r-1,s-1,t-1} with probability WMate[m-1,n-1,o-1,p-1,q-1,r-1,s-1,t-1].  With probability O*c, her mating attempt cannot be recouped and so her fitness is WMate (reduced below 1 to the extent that she has dislikes).  With probability (1-O*c), she can recoup her mating attempt if she rejects the male and so she is guaranteed to have a fitness of 1 (i.e., we normalize by her mean preference, NormalFemale).

Note that we assume here that c is potentially strong (as in the plant model)

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, 
                          t - 1] = 
                        c*WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1] + \((1 - c)\)*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                                s - 1, t - 1]/
                              NormalFemale\_{m - 1, n - 1, o - 1, p - 1}]]]]]]]];\)\)

Calculate the mean fitness of the population

\(\(M\&_ = 0;\)\)
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      M\&_ = M\&_ + 
                          X\_{m - 1, n - 1, o - 1, p - 1}'*
                            X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]]]]]]]]];\)\)
\(\(M\&_ = Collect[M\&_, c, Factor];\)\)

Calculate frequencies of mated pairs

Here we add a fixed cost of assortative mating, cf, which always decreases in females who non-randomly mate at higher rates (cf is also allowed to be strong so that the results presented also apply here, to leading order):

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*δ + O*κ + O*ρ)\)*\((cf)\))\) /. 
                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                            1]\)])\)
]]]];\)\)

meanfertility = 1 + Factor[meanfertility - 1];

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((O*δ + 
                                        O*κ + O*ρ)\)*\((cf)\))\) /. 
                              ModMat[\([\((n - 1)\) + \((p - 1)\) + 1]\)])\)*
                          X\_{q - 1, r - 1, s - 1, t - 1}'*
                          WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]/\((meanfertility*
                                M\&_)\)]]]]]]]];\)\)

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), etc.} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm])), ( (Subscript[δ, Mm]) - (Subscript[δ, mm])) == 
              hδ*( (Subscript[δ, MM]) - (Subscript[δ, mm])), Δδ == ((Subscript[P, M]) ( (Subscript[δ, MM]) - (Subscript[δ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[δ, Mm]) - (Subscript[δ, mm]))), 
aveδ == ((Subscript[P, M]^2) (Subscript[δ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[δ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[δ, mm])), ( (Subscript[κ, Mm]) - (Subscript[κ, mm])) == 
              hκ*( (Subscript[κ, MM]) - (Subscript[κ, mm])), Δκ == ((Subscript[P, M]) ( (Subscript[κ, MM]) - (Subscript[κ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[κ, Mm]) - (Subscript[κ, mm]))), 
aveκ == ((Subscript[P, M]^2) (Subscript[κ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[κ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[κ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), (Subscript[δ, mm]), (Subscript[δ, Mm]), (Subscript[δ, MM]), (Subscript[κ, mm]), (Subscript[κ, Mm]), (Subscript[κ, MM])}] // Flatten

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do change the frequency of A in the preference-based model (Equation 15):

Collect[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]] /. 
        subTrans, {c, cf, aveρ, aveδ, aveκ}, 
      Factor]

Δ(Subscript[P, A]) after recombination can be written as:

Δ(Subscript[PR, A]) =  (1/2) (1 + 
              c) O (Subscript[P, A]) (1 - 
              (Subscript[P, A])) (- 
                  aveρ (1 - (Subscript[P, A])) (Subscript[P, A]) (1 - 2 (Subscript[P, A])) -  
              aveκ (((1 - 2 (Subscript[P, A])))^3) + 
              aveδ  (1 - 2 (Subscript[P, A])) (1 - 3 (Subscript[P, A]) + 
                    3 (Subscript[P, A]^2)));

    Factor[%% - Δ(Subscript[PR, A])]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

Now, to order O, the costs of non-random mating do change the frequency of M:

\(ΔPR\_M = 
      Collect[Normal[Series[\((P\_M' - P\_M /. SubDSmall)\), {O, 0, 1}]] /. 
          subTrans, {c, cf, D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, 
          D\_{AM, MF}, D\_{AM, MM, AF}, D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF}}, Factor]\)

The relative costs depend on the change in pickiness of the females:

ChangeInPickiness =   O (Δδ*
                        mate0 + Δκ*
                        mate1 + Δρ*mate2) /. 
                mate0 -> (((1 - (Subscript[P, A])))^4)  + (((2 (1 - (Subscript[P, A])) (Subscript[P, A])))^2) + (Subscript[P, A]^4) /. 
              mate1 -> 4 (1 - (Subscript[P, A])) (Subscript[P, A]) ((((1 - (Subscript[P, A])))^2)  + 
                      (Subscript[P, A]^2)) /. mate2 -> 2 (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) // 
          Factor;

Note that 2 (((1 - (Subscript[P, A])))^2) (Subscript[P, A]^2) is the probability that opposite homozygotes would have mated while 4 (1 - (Subscript[P, A])) (Subscript[P, A]) ((((1 - (Subscript[P, A])))^2)  + (Subscript[P, A]^2)) is the probability that matings would have occured with males that differ by one allele.

Altogether, the change in the modifier can be written as:

-(1/2) cf O (Δρ + Δδ + Δκ) (1 - (Subscript[P, M])) (Subscript[P, M]) - 
          (1/2) c ChangeInPickiness (1 - (Subscript[P, M])) (Subscript[P, M]);
Factor[% - Δ(Subscript[PR, M])]

This is order O and does not involve the association measures.  The association measures enter only to order (O^2) (see PHASE 1) and therefore influence the dynamics only when costs are weak (previous section).

Appendix B:  General preference-based model

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assume that assortative mating depends on the "A" (or i,k or m,o or q,s) locus which is also responsible for coevolution

Read the matrix below as female genotypes in rows, male genotypes in columns, assuming female choice...
We assume that females have dislikes:
	* for any different genotype  (ρ).

Such dislikes cause a reduction in female fitness (a direct cost of mate choice).

MatrixForm[
      MateMat = {{1 - O *ρ[11], 1 - O *ρ[12], 
            1 - O *ρ[13]}, {1 - O *ρ[21], 1 - O *ρ[22], 
            1 - O *ρ[23]}, {1 - O *ρ[31], 1 - O*ρ[32], 
            1 - O *ρ[33]}}]

Only the female's modifier status affects the strength of preference:

ModMat = {{ρ[x_] -> (Subscript[ρ, mm])[x]}, {ρ[
                x_] -> (Subscript[ρ, Mm])[x]}, {ρ[x_] -> (Subscript[ρ, MM])[
                x]}};

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Define fitness of mated pairs

In the function below, female genome is given by {m,n,o,p} and male genome by {q,r,s,t} where letters take values 0 or 1 depending on allelic status at that position in the genome.

WMate[m_, n_, o_, p_, q_, r_, s_, t_] := 
        MateMat[[m + o + 1, q + s + 1]] /. 
          ModMat[[n + p + 1]];

Normalize WMate so that all females are mated

\(For[m = 1, 
      m ≤ 2, \(m++\), 
For[n = 1, 
        n ≤ 2, \(n++\), 
For[o = 1, 
          o ≤ 2, \(o++\), 
For[p = 1, 
            p ≤ 2, \(p++\), 
            NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 0]]]]\)

\(\(\(
\)\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 
                        NormalFemale\_{m - 1, n - 1, o - 1, p - 1} + 
                          X\_{q - 1, r - 1, s - 1, t - 1}' 
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]]]]]]]]];\)\(
\)
    \)\)\)

Here we add a relative cost of assortative mating, c, which decreases fitness in proportion to the average degree of dislikes exhibited.  Specifically, a female of genotype {m-1,n-1,o-1,p-1} will mate with a male of genotype {q-1,r-1,s-1,t-1} with probability WMate[m-1,n-1,o-1,p-1,q-1,r-1,s-1,t-1].  With probability O*c, her mating attempt cannot be recouped and so her fitness is WMate (reduced below 1 to the extent that she has dislikes).  With probability (1-O*c), she can recoup her mating attempt if she rejects the male and so she is guaranteed to have a fitness of 1 (i.e., we normalize by her mean preference, NormalFemale).

Note that we assume here that c is small (of order O).  In the next section, we allow c to be large (e.g., 1 as in the plant model).

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, 
                          t - 1] = 
                        O*c*WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1] + \((1 - O*c)\)*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                                s - 1, t - 1]/
                              NormalFemale\_{m - 1, n - 1, o - 1, p - 1}]]]]]]]];\)\)

Calculate the mean fitness of the population

\(\(M\&_ = 0;\)\)
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      M\&_ = M\&_ + 
                          X\_{m - 1, n - 1, o - 1, p - 1}'*
                            X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]]]]]]]]];\)\)
\(\(M\&_ = Collect[M\&_, c, Factor];\)\)

Calculate frequencies of mated pairs

Fixed costs are not explicitly added because this cost will depend on the various changes to the preference matrix.  Instead, we denote the fixed cost to females as cf*Δρ (for some unspecified Δρ), which is an overall measure of the costs accounting for the change to the entire matrix.

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = X\_{m - 1, n - 1, o - 1, p - 1}'*X\_{q - 1, r - 1, s - 1, t - 1}'*
                          WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]/M\&_]]]]]]]];\)\)

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

When assortative mating is rare, all association measures (including the departure from HW) will be small (some will be even smaller than that assumed below, but this will only matter if they appear in the solution).  We can keep track of the fact that the association measures are small by explicitly multiplying each association measure by the small term "O":

\(\(SubDSmall = {D\_{AM, AF} -> O*D\_{AM, AF}, 
          D\_{MM, MF} -> O*D\_{MM, MF}, 
          D\_{AM, MM} -> O*D\_{AM, MM}, 
          D\_{AM, MF} -> O*D\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after offspring production (X''):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

In the QLE analysis, the levels of assortative mating {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])} often enter into the results more naturally as the average level of assortative mating  and the change in assortative mating caused by randomly replacing an m allele with an M allele.   We thus use the following transformation to simplify the results in terms of the average level of assortment,the change in assortment,and the dominance at the modifier locus:

\(subTrans = 
      Solve[{\((\ ρ\_Mm[x_] - ρ\_mm[x_])\) == 
              hρ*\((\ ρ\_MM - ρ\_mm)\), Δρ == \((P\_M\ \((\ ρ\_MM - ρ\_Mm)\) + \((1 - 
                        P\_M)\)\ \((\ ρ\_Mm - ρ\_mm)\))\), 
aveρ == \((P\_M\%2\ ρ\_MM + 
                  2  P\_M\ \((1 - 
                        P\_M)\) ρ\_Mm + \(\((1 - 
                            P\_M)\)\^2\) ρ\_mm)\)}, {ρ\_mm, ρ\_Mm, ρ\_MM}] // Flatten\)

subTrans = {(Subscript[ρ, mm])[
              x_] -> -((aveρ[x] hρ[x] + 
                    aveρ[x] (Subscript[P, M]) - 2 aveρ[x] hρ[x] (Subscript[P, M]) - 
                    2 hρ[x] (Subscript[P, M]) Δρ[x] - 
                    (Subscript[P, M]^2) Δρ[x] + 
                    2 hρ[x] (Subscript[P, M]^2) Δρ[
                        x])/(-hρ[x] - (Subscript[P, M]) + 
                    2 hρ[x] (Subscript[P, M]))), (Subscript[ρ, Mm])[
              x_] -> -((aveρ[x] hρ[x] + 
                    aveρ[x] (Subscript[P, M]) - 2 aveρ[x] hρ[x] (Subscript[P, M]) + 
                    hρ[x] Δρ[x] - 
                    2 hρ[x] (Subscript[P, M]) Δρ[x] - 
                    (Subscript[P, M]^2) Δρ[x] + 
                    2 hρ[x] (Subscript[P, M]^2) Δρ[
                        x])/(-hρ[x] - (Subscript[P, M]) + 
                    2 hρ[x] (Subscript[P, M]))), (Subscript[ρ, MM])[
              x_] -> -((aveρ[x] hρ[x] + 
                    aveρ[x] (Subscript[P, M]) - 
                    2 aveρ[x] hρ[x] (Subscript[P, M]) + Δρ[
                      x] - 2 hρ[x] (Subscript[P, M]) Δρ[x] - 
                    (Subscript[P, M]^2) Δρ[x] + 
                    2 hρ[x] (Subscript[P, M]^2) Δρ[
                        x])/(-hρ[x] - (Subscript[P, M]) + 
                    2 hρ[x] (Subscript[P, M])))};

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do change the frequency of A in the preference-based model:

part1 = 
      Collect[Normal[
          Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]], {aveρ, 
          aveδ, aveκ}, Factor]

Factor[part1 /. subTrans]

Δ(Subscript[P, A]) after recombination can be written as (Equation B2a and B2b):

Δ(Subscript[PR, A]) =  -(1/2) O (1 - 
              (Subscript[P, A])) (Subscript[P, A]) 
          Factor[((((1 - 
                          (Subscript[P, A])))^2) ((aveρ[13] - 
                            aveρ[12])  (Subscript[P, A]) + (aveρ[12] - 
                            aveρ[11]) (1 - (Subscript[P, A]))) + 
                2  (Subscript[P, A]) (1 - 
                      (Subscript[P, A])) ((aveρ[23] - 
                            aveρ[22])  (Subscript[P, A]) + (aveρ[22] - 
                            aveρ[21]) (1 - 
                            (Subscript[P, A]))) + (Subscript[P, A]^2) ((aveρ[33] - 
                            aveρ[32])  (Subscript[P, A]) + (aveρ[32] - 
                            aveρ[31]) (1 - 
                            (Subscript[P, A]))))];

    Factor[Δ(Subscript[PR, A])/part1 /. subTrans]

In the text, we wish to consider strong costs as well as weak, which can be incorporated by removing the order of c (Equation B2a and B2c):

Factor[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) - part1 /. SubDSmall) /. 
              c -> c/O, {O, 0, 1}]] /. subTrans]

costterm = 
      Factor[((((1 - 
                      (Subscript[P, A])))^2) ((aveρ[31] - 
                        aveρ[21])  (Subscript[P, A]) + (aveρ[21] - 
                        aveρ[11]) (1 - (Subscript[P, A]))) + 
            2  (Subscript[P, A]) (1 - 
                  (Subscript[P, A])) ((aveρ[32] - 
                        aveρ[22])  (Subscript[P, A]) + (aveρ[22] - 
                        aveρ[12]) (1 - 
                        (Subscript[P, A]))) + (Subscript[P, A]^2) ((aveρ[33] - 
                        aveρ[23])  (Subscript[P, A]) + (aveρ[23] - 
                        aveρ[13]) (1 - (Subscript[P, A]))))]

Factor[%%/costterm /. subTrans]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the preference-based model:

Δ(Subscript[PR, M]) = 
      Factor[Normal[
          Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]]]

To order (O^2), the costs of non-random mating do change the frequency of M, as do the association measures becuase of sexual selection:

\(ΔPR2\_M = 
      O\^2\/2*Collect[
          D[\((P\_M' - P\_M /. SubDSmall)\), {O, 2}] /. O -> 0, {c, 
            D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
            D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
          Factor]\)

\(Collect[ΔPR2\_M /. subTrans, {c, D\_{AM, AF}, 
        D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, D\_{AM, MM, AF}, 
        D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, Factor]\)

In the following derivation of the association measures, we will need the overall change in allele frequency across the generation (including both selection and mating) to order O.  We do not need to keep considering the possibility that costs are strong, because if they are then the association terms won't matter.

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) (-(1 - (Subscript[P, A])) (Subscript[S, aa])[
                    (Subscript[P, A])] + (1 - 2 (Subscript[P, A])) (Subscript[S, Aa])[(Subscript[P, A])] + 
                (Subscript[P, A]) (Subscript[S, AA])[(Subscript[P, A])]) + part1;

     Δ(Subscript[P, M]) = 0;

The QLE association measures must now be calculated to give the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

This can be rewritten in terms of Δ(Subscript[P, A]) and the degree of dominance induced by both natural and sexual selection:

The overall fitness of the genotypes (including sexual and natural selection is given by):

overallfit = {(Subscript[W, AA])[x_] -> 
            1 + (Subscript[S, AA])[x] - 
              1/2   ((((1 - x))^2) aveρ[13] + 
                    2  x (1 - x) aveρ[23] + (x^2) 
                      aveρ[33]), 
          (Subscript[W, Aa])[x_] -> 
            1 + (Subscript[S, Aa])[x] - 
              1/2  ((((1 - x))^2) aveρ[12] + 
                    2  x (1 - x) aveρ[22] + (x^2) 
                      aveρ[32]), 
(Subscript[W, aa])[x_] -> 
            1 + (Subscript[S, aa])[x] - 
              1/2  ((((1 - x))^2) aveρ[11] + 
                    2  x (1 - x) aveρ[21] + (x^2) 
                      aveρ[31])};

This allows us to write the fitness advantage of homozygotes as:

(Subscript[H, animal]) = 
      (Subscript[W, AA])[(Subscript[P, A])] - 2 (Subscript[W, Aa])[(Subscript[P, A])] + (Subscript[W, aa])[(Subscript[P, A])] /. overallfit // 
        Factor

which is equal to (Subscript[H, ns]) and (Subscript[H, ss]), where the latter is (Equation B4):

(1/2) ((((1 - (Subscript[P, A])))^2) ((1 - aveρ[11]) - 
                  2 (1 - aveρ[12]) + (1 - aveρ[13]))  + 
            2 (Subscript[P, A]) (1 - (Subscript[P, A])) ((1 - aveρ[21]) - 
                  2 (1 - aveρ[22]) + (1 - 
                      aveρ[23]))  + (Subscript[P, A]^2) ((1 - 
                      aveρ[31]) - 
                  2 (1 - aveρ[32]) + (1 - 
                      aveρ[
                        33])) );

Factor[(Subscript[H, animal]) - %]

The relative costs depend on the change in pickiness of the females (Equation B3b):

Z[1] = (((1 - (Subscript[P, A])))^2) Δρ[11] + 
          2 (1 - (Subscript[P, A])) (Subscript[P, A]) Δρ[12] + 
          (Subscript[P, A]^2) Δρ[13];
Z[2] = (((1 - (Subscript[P, A])))^2) Δρ[21] + 
          2 (1 - (Subscript[P, A])) (Subscript[P, A]) Δρ[22] + 
          (Subscript[P, A]^2) Δρ[23];
Z[3] = (((1 - (Subscript[P, A])))^2) Δρ[31] + 
          2 (1 - (Subscript[P, A])) (Subscript[P, A]) Δρ[32] + 
          (Subscript[P, A]^2) Δρ[33];

ChangeInPickiness =  
        O ((((1 - (Subscript[P, A])))^2) Z[1] + 2 (1 - (Subscript[P, A])) (Subscript[P, A]) Z[2] + 
              (Subscript[P, A]^2) Z[3]);

\(Factor[ΔP2\_M - \((\ \ O\ \(D\_{AM, MM, AF}\) 
                O\ H\_animal + 
              O \((D\_{AM, MF} + 
                    D\_{AM, MM})\) \(\(\ \)\(ΔP\_A\)\)\/\(\((1 - P\_A)\)\ P\_A\))\) /. subTrans]\)

Factor[% - (-(1/2) O c ChangeInPickiness (1 - 
                (Subscript[P, M])) (Subscript[P, M]))]

Hence we need to derive the QLE values for the THREE  association measures given above.

The following must equal zero at QLE:

\(eqn\_{AM, MM} = 
      Collect[D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                SimpleSubs\) /. SubDSmall, O] /. O -> 0, {O, c, cf, 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MF} = 
      Collect[D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                SimpleSubs\) /. SubDSmall, O] /. O -> 0, {O, c, cf, 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, O] /. O -> 0, {O, c, cf, 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

If interested in the average level of homozygosity at QLE:

\(eqn\_{AM, AF} = 
      Collect[D[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔP\_M\) /. 
                            P\_A -> P\_A + ΔP\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, O] /. O -> 0, {O, c, cf, \ 
          D\_{AM, AF}, D\_{MM, MF}, D\_{AM, MM}, D\_{AM, MF}, 
          D\_{AM, MM, AF}, D\_{AM, MM, MF}, D\_{AM, MM, AF, MF}}, 
        Factor]\)

Adding together the change in \(\(\(\ \)\(D\_{AM, AF}\)\)\) due to natural selection and mating:

\(\(O\ \((\(-1\) + P\_A)\)\^2\ P\_A\%2\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
              S\_AA[P\_A])\) + O\ \((eqn\_{AM, AF})\);\)\)

which can be solved to give the QLE prediction for the departure from Hardy-Weinberg, \(\(\(\ \)\(D\_{AM, AF}\)\)\):

\(D\_{AM, AF} /. \((Solve[% == 0, D\_{AM, AF}] // Flatten)\) // 
      Simplify\)

Factor[% /. subTrans]

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
                eqn\_{AM, MM, AF} == 0}, {D\_{AM, MM}, D\_{AM, MF}, 
                D\_{AM, MM, AF}}] /. subTrans // Simplify\) // 
        Flatten\)

finalΔ(Subscript[P2, M]) = 
      Factor[Δ(Subscript[P2, M]) /. subQLE /. subTrans]

which can be written using the following terms.   

The change caused by the modifier on \(D\_{AM, AF}\)(looking only at change in \(D\_{AM, AF}\)caused by mating):

Dterm = -(((-1 + (Subscript[P, A])))^2) (Subscript[P, A]^2) (aveρ[11] - 
              aveρ[12] - aveρ[21] + aveρ[22] - 
              2 aveρ[11] (Subscript[P, A]) + 3 aveρ[12] (Subscript[P, A]) - 
              aveρ[13] (Subscript[P, A]) + 3 aveρ[21] (Subscript[P, A]) - 
              4 aveρ[22] (Subscript[P, A]) + aveρ[23] (Subscript[P, A]) - 
              aveρ[31] (Subscript[P, A]) + aveρ[32] (Subscript[P, A]) + 
              aveρ[11] (Subscript[P, A]^2) - 2 aveρ[12] (Subscript[P, A]^2) + 
              aveρ[13] (Subscript[P, A]^2) - 2 aveρ[21] (Subscript[P, A]^2) + 
              4 aveρ[22] (Subscript[P, A]^2) - 2 aveρ[23] (Subscript[P, A]^2) + 
              aveρ[31] (Subscript[P, A]^2) - 2 aveρ[32] (Subscript[P, A]^2) + 
              aveρ[33] (Subscript[P, A]^2) - (Subscript[S, aa])[(Subscript[P, A])] + 2 (Subscript[S, Aa])[(Subscript[P, A])] - 
              (Subscript[S, AA])[(Subscript[P, A])]);
(((Subscript[P, M]) 
                    Dterm /. {aveρ[x_] -> (Subscript[ρ, MM]) [
                        x]}) + ((1 - (Subscript[P, M])) 
                    Dterm /. {aveρ[x_] -> (Subscript[ρ, Mm]) [
                        x]})) - (((Subscript[P, M]) 
                    Dterm /. {aveρ[x_] -> (Subscript[ρ, Mm]) [
                        x]}) + ((1 - (Subscript[P, M])) 
                    Dterm /. {aveρ[x_] -> (Subscript[ρ, mm]) [x]})) // 
        Factor;
\(ΔD\_{AM, AF} = \((2 \((1 - P\_A)\)\^2\ P\_A\%2)\) 
        Collect[%/\((2 \((1 - P\_A)\)\^2\ P\_A\%2)\) /. 
            subTrans, Δρ[x_], Factor]\)

\(D\_{AM, MM, AF}\) is proportional to \(ΔD\_{AM, AF}\)(Equation 20a):

\(\(\(\(\((1 - P\_M)\)\ P\_M\)\/2\ ΔD\_{AM, AF};\)\(
\)
    \)\)
\(Factor[%/D\_{AM, MM, AF} /. subQLE]\)

The change caused by the modifier on Δ(Subscript[P, A]) (Equation B5a):

ΔPAterm = 
        Factor[Δ(Subscript[P, A]) /. subTrans] /. 
          aveρ[x_] -> ρ[x];
(((Subscript[P, M]) ΔPAterm /. {ρ[x_] -> (Subscript[ρ, MM])[
                        x] }) + ((1 - 
                        (Subscript[P, M])) ΔPAterm /. {ρ[
                        x_] -> (Subscript[ρ, Mm])[
                        x]})) - (((Subscript[P, M]) ΔPAterm /. {ρ[x_] -> (Subscript[ρ, Mm])[x]}) + ((1 - 
                        (Subscript[P, M])) ΔPAterm /. {ρ[
                        x_] -> (Subscript[ρ, mm])[x]})) // 
        Factor;
Δψ = Factor[% /. subTrans]

-(((1 - (Subscript[P, A])) (Subscript[P, A]))/2) 
        O ((((1 - (Subscript[P, A])))^2) ((Δρ[
                          13] - Δρ[
                          12])  (Subscript[P, A]) + (Δρ[
                          12] - Δρ[11]) (1 - 
                        (Subscript[P, A]))) + 
            2  (Subscript[P, A]) (1 - 
                  (Subscript[P, A])) ((Δρ[
                          23] - Δρ[
                          22])  (Subscript[P, A]) + (Δρ[
                          22] - Δρ[21]) (1 - 
                        (Subscript[P, A]))) + (Subscript[P, A]^2) ((Δρ[
                          33] - Δρ[
                          32])  (Subscript[P, A]) + (Δρ[
                          32] - Δρ[31]) (1 - 
                        (Subscript[P, A]))));

Δψ/% // Factor

In this model, Δψ is not proportional to \(ΔD\_{AM, AF}\).

\(Factor[Δψ/ΔD\_{AM, AF}]\)

Altogether, the change in the modifier can be written as:

\(\(O\^2\ H\_animal\ D\_{AM, MM, AF} + \(\(\(ΔP\_A\)\(\ \)\)\/\(\((1 - P\_A)\)\ P\_A\)\) \((O\ \ D\_{AM, MM} + 
                O\ \ D\_{AM, MF})\)\  - 
          1\/2\ O\ c\ ChangeInPickiness \((1 - P\_M)\)\ P\_M /. 
        subQLE;\)\)
Factor[% - finalΔ(Subscript[P2, M]) /. subTrans]

\(\(1\/2\) 
            O\^2\ \((1 - 
                P\_M)\)\ \(P\_M\) ΔD\_{AM, AF}\ H\_animal\) +\(\(\(\(ΔP\_A\)\(\ \)\)\/\(\((1 - 
                      P\_A)\)\ P\_A\)\) \((O\ \ D\_{AM, MM} + 
                O\ \ D\_{AM, MF})\)\) -(1/2) O c ChangeInPickiness (1 - (Subscript[P, M])) (Subscript[P, M])/.subQLE;
Factor[% - finalΔ(Subscript[P2, M]) /. 
        subTrans]

\(\(\(1\/2\) 
            O\^2\ \((1 - 
                P\_M)\)\ \(P\_M\) ΔD\_{AM, AF}\ H\_animal\  + \(\(\(ΔP\_A\)\(\ \)\)\/\(\((1 - P\_A)\)\ P\_A\)\) 
            2 \((1 - P\_M)\)\ \(P\_M\) \((Δψ)\)\  - 
          1\/2\ O\ c\ ChangeInPickiness \((1 - P\_M)\)\ P\_M /. 
        subQLE;\)\)
Factor[% - finalΔ(Subscript[P2, M]) /. subTrans]

QLE results allowing high levels of assortment

PHASE 1: NATURAL SELECTION
(common to all forms of assortative mating)

We start the life cycle after offspring have been produced and after we have randomized which chromosomes we consider to be from the mother and which from the father,because there is no imprinting or other effects that cause maternal and paternal chromosomes to behave differently.The life cycle is then:
	*Natural Selection
	*Assortative Mating
	*Recombination and offspring production
	*Randomization of maternal/paternal chromosome labels within an individual
	*Census

Natural selection

Fitness

Selection is allowed to depend on the genotypic frequencies.  To remind us of this fact, we write the selection coefficient for genotype i at the A locus as (Subscript[S, i])[(Subscript[P, A])], although we technically allow (Subscript[S, i]) to depend on the genotype frequencies at the A locus and not just the allele frequencies.

\(\(W\_{0, 0, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 0, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{0, 1, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 0, 1, 1} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 1, 1, 1} = 1 + O*S\_AA[P\_A];\)\)

The mean fitness:

\(\(W\&_ = 
        Factor[\(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0} + \(X\_{0, 0, 0, 1}\) 
                W\_{0, 0, 0, 1} + \(X\_{0, 0, 1, 0}\) 
                W\_{0, 0, 1, 0} + \(X\_{0, 1, 0, 0}\) 
                W\_{0, 1, 0, 0} + \(X\_{1, 0, 0, 0}\) 
                W\_{1, 0, 0, 0} + \(X\_{0, 0, 1, 1}\) 
                W\_{0, 0, 1, 1} + \(X\_{0, 1, 0, 1}\) 
                W\_{0, 1, 0, 1} + \(X\_{1, 0, 0, 1}\) 
                W\_{1, 0, 0, 1} + \(X\_{0, 1, 1, 0}\) 
                W\_{0, 1, 1, 0} + \(X\_{1, 1, 0, 0}\) 
                W\_{1, 1, 0, 0} + \(X\_{1, 0, 1, 0}\) 
                W\_{1, 0, 1, 0} + \(X\_{0, 1, 1, 1}\) 
                W\_{0, 1, 1, 1} + \(X\_{1, 1, 1, 0}\) 
                W\_{1, 1, 1, 0} + \(X\_{1, 0, 1, 1}\) 
                W\_{1, 0, 1, 1} + \(X\_{1, 1, 0, 1}\) 
                W\_{1, 1, 0, 1} + \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1} /. 
            SimpleSubs];\)\)

Genotype frequencies after selection

\(\(X\_{0, 0, 0, 0}' = \(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = \(X\_{0, 0, 0, 1}\) W\_{0, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = \(X\_{0, 0, 1, 0}\) W\_{0, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = \(X\_{0, 1, 0, 0}\) W\_{0, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = \(X\_{1, 0, 0, 0}\) W\_{1, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = \(X\_{0, 0, 1, 1}\) W\_{0, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = \(X\_{0, 1, 0, 1}\) W\_{0, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = \(X\_{1, 0, 0, 1}\) W\_{1, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = \(X\_{0, 1, 1, 0}\) W\_{0, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = \(X\_{1, 1, 0, 0}\) W\_{1, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = \(X\_{1, 0, 1, 0}\) W\_{1, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = \(X\_{0, 1, 1, 1}\) W\_{0, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = \(X\_{1, 1, 1, 0}\) W\_{1, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = \(X\_{1, 0, 1, 1}\) W\_{1, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = \(X\_{1, 1, 0, 1}\) W\_{1, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)

QLE analysis - natural selection only

We now allow the resident population to mate assortatively at high rates.  Consequently, there can be a substantial (order one) departure from Hardy-Weinberg, which we call \(D0\_{AM, AF}\).  By replacing \(D\_{AM, AF}\) with its power series \(D0\_{AM, AF} + O*D1\_{AM, AF} + O\^2*D2\_{AM, AF} +  ... \) , we can solve the successive terms in the power series (including the leading term \(D0\_{AM, AF}\)) by taking Taylor series approximations to different orders in O.

The remaining association measures all involve the modifier allele, but because we assume that the modifier has a weak effect (order O), these additional association measures must all be order O (or smaller).

\(\(SubDSmall = {D\_{AM, AF} -> D0\_{AM, AF} + O*D1\_{AM, AF}, 
          D\_{MM, MF} -> O*D1\_{MM, MF}, 
          D\_{AM, MM} -> O*D1\_{AM, MM}, 
          D\_{AM, MF} -> O*D1\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D1\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D1\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D1\_{AM, MM, AF, MF}};\)\)

The following let's us use the diploid genome frequencies obtained after selection (X'):

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))'};

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

Simplify[
      Normal[Series[((Subscript[P, A])' - (Subscript[P, A]) /. SubDSmall), {O, 0, 1}]]]

Δ(Subscript[P, A]) can be written as:

\(\(\(\ \)\(ΔPS\_A = 
        O\ \((1 - 
                P\_A)\)\ P\_A\ \((P\_A\ \((S\_AA[P\_A] - 
                      S\_Aa[P\_A])\) + \((1 - P\_A)\)\ \((S\_Aa[P\_A] - 
                      S\_aa[P\_A])\))\) - 
          O\ D0\_{AM, AF}\ \((\((1 - P\_A)\)\ \ \((S\_AA[P\_A] - 
                      S\_Aa[P\_A])\) + 
                P\_A\ \((S\_Aa[P\_A] - S\_aa[P\_A])\))\);\)\)\)

Factor[%% - Δ(Subscript[PS, A])]

Modifier change:

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, there is no change in the modifier frequency:

Δ(Subscript[PS, M]) = 
      Simplify[Normal[
          Series[((Subscript[P, M])' - (Subscript[P, M]) /. SubDSmall), {O, 0, 1}]]]

However, to order (O^2), there is a change in the modifier frequency that is driven by three association measures (\(D\_{AM, MM, AF}\), \(D\_{AM, MF}\), and \(D\_{AM, MM}\)):

\(ΔPS\_M = 
      Collect[Normal[
          Series[\((P\_M' - P\_M /. SubDSmall)\), {O, 0, 2}]], {D1\_{AM, AF}, 
          D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
          D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

Defining the fitness advantage of homozygotes over heterozygotes due to natural selection as:

(Subscript[H, ns]) = 
      O*(Subscript[S, AA])[(Subscript[P, A])] - 2 O*(Subscript[S, Aa])[(Subscript[P, A])] + O*(Subscript[S, aa])[(Subscript[P, A])] // Factor

we can write the change in modifier frequency due to natural selection as:

\(\(\(O\ D1\_{AM, MM, AF}\ H\_ns + 
        O\ D1\_{AM, MM}\ \ \((ΔPS\_A /. D0\_{AM, AF} -> 0)\)\/\(\((1 - P\_A)\)\ P\_A\)\  + 
        O\ D1\_{AM, MF}\ \((ΔPS\_A /. D0\_{AM, AF} -> 0)\)\/\(\((1 - P\_A)\)\ P\_A\);\)\(
\)
    \)\)
Factor[% - Δ(Subscript[PS, M])]

Note that this doesn't depend on the total change in the frequency of A due to selection, but just that component that does not depend on the departure from HW.

Hence we will need to derive the QLE values for these three association measures.

The following demonstrate that, to leading order, the change in these three association measures due to selection is zero:

\(eqnS\_{AM, MM} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

\(eqnS\_{AM, MF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

\(eqnS\_{AM, MM, AF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - D\_{AM, MM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

That is, selection does not by itself generate an association between the modifier and the selected loci.

Selection can, however, generate a departure from HW:

\(eqnS\_{AM, AF} = 
      Simplify[Normal[
          Series[\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. 
                              P\_M -> P\_M + ΔPS\_M\) /. 
                            P\_A -> P\_A + ΔPS\_A\) /. 
                          subnextgen\) /. ChangeVars)\) - \ D\_{AM, AF})\) /. 
                SimpleSubs\) /. SubDSmall, {O, 0, 1}]]]\)

PHASE 2: MATING

GROUP-BASED MODEL:  Genotypic assortment ((Subscript[g, AA, 1]) = (Subscript[g, Aa, 2]) = (Subscript[g, aa, 3]) = 
              1)
-> With fixed and relative costs

group[1, 2] = 0;
group[1, 3] = 0;
group[2, 1] = 0;
group[2, 3] = 0;
group[3, 1] = 0;
group[3, 2] = 0;

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assumes that assortative mating depends on the "A" locus which is also responsible for coevolution.

Also assumes that assortment entails a cost that decreases with the frequency of the class within which assortment occurs.

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Individuals of genotype i at the A locus join group j with probability group[i,j].  For clarity, we say that Group 1 is the group toward which aa tends to go, group3 is the group toward which AA tends to go.  But the only restriction that we make is that all individuals join some group so that:

group[1, 1] = 1 - group[1, 2] - group[1, 3];
group[2, 2] = 1 - group[2, 1] - group[2, 3];
group[3, 3] = 1 - group[3, 1] - group[3, 2];

We assume that females choose a mate from within her group with a probability ρ, the strength of which is determined by her modifier genotype:

ModMat = {ρ -> (Subscript[ρ, mm]), ρ -> (Subscript[ρ, Mm]), ρ -> (Subscript[ρ, MM])};

First assortative mating occurs according to the genotype at the A locus (mating is written in the order female x male, and it is assumed that females control whether they mate within the genotypic class or randomly).  A small cost is added in proportion to the rarity of the class.  If freq(class) = 1, there is no reduction in fertility.  If freq(class) ~ 0, fertility is reduced by a factor 1-O*c.

The proportion of individuals in each of the three groups is given in the vector freq:

freq = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
freq = 
                freq + {X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 1], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                    X\_{m - 1, n - 1, o - 1, p - 1}'*
                      group[m + o - 1, 
                        3]}
]]]];\)\)
freq = Factor[freq];

The following confirms that the frequencies of all groups sums to one:

stillone = 
      Factor[Sum[freq[[i]], {i, 1, 3}] /. ChangeVars]

The average probability that a female mates within her group for each of the three groups is given by the vector meanpref:

meanpref = {0, 0, 0};
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanpref = 
                meanpref + \((ρ /. 
                        ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                              1]\)])\)*{X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 1], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*group[m + o - 1, 2], 
                      X\_{m - 1, n - 1, o - 1, p - 1}'*
                        group[m + o - 1, 
                          3]}
]]]];\)\)
meanpref = Factor[meanpref];

A small cost is added in proportion to the rarity of the group.  If freq(group) = 1, there is no reduction in fertility.  If freq(group) ~ 0, fertility is reduced by a factor 1-O*c.  That is, c is a relative cost that declines linearly with the frequency of the group.

In addition, cf is a fixed cost of mating within the group.

meanfertility = 0;
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
meanfertility = 
                meanfertility + 
\((X\_{m - 1, n - 1, o - 1, p - 1}'*\((1 - \((ρ)\)*\((O*cf)\) - \((ρ)\)*\((O*
                                  c)\)*\((group[m + o - 1, 
                                      1]*\((1 - freq[\([1]\)])\) + 
                                  group[m + o - 1, 
                                      2]*\((1 - freq[\([2]\)])\) + 
                                  group[m + o - 1, 
                                      3]*\((1 - freq[\([3]\)])\))\))\) /. 
                      ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                            1]\)])\)
]]]];\)\)

\(\(meanfertility = 
        1 + Factor[meanfertility - 1] /. 
          X\_{0, 0, 0, 0} + 2\ X\_{0, 1, 0, 0} + X\_{0, 1, 0, 1} + 
              2\ X\_{1, 0, 0, 0} + 2\ X\_{1, 0, 0, 1} + X\_{1, 0, 1, 0} + 
              2\ X\_{1, 1, 0, 0} + 2\ X\_{1, 1, 0, 1} + 2\ X\_{1, 1, 1, 0} + 
              X\_{1, 1, 1, 1} -> 1;\)\)

meanfertilityEQUALS = (1 - 
            cf O (meanpref[[1]] + meanpref[[2]] + 
                  meanpref[[3]]) - 
            c O ((1 - freq[[1]])*
                    meanpref[[1]] + (1 - freq[[2]])*
                    meanpref[[2]] + (1 - freq[[3]])*
                    meanpref[[3]]));

Factor[meanfertility - meanfertilityEQUALS]

Females mate assortatively with probability O*ρ and otherwise mate randomly (we assume that male mating opportunities are not affected by having already assortatively mated):

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
AM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((group[m + o - 1, 1]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 1]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*ρ/
                                  freq[\([1]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([1]\)])\))\) + 
                              group[m + o - 1, 2]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 2]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*ρ/
                                  freq[\([2]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([2]\)])\))\) + 
                              group[m + o - 1, 3]*
                                X\_{m - 1, n - 1, o - 1, p - 1}'*
                                group[q + s - 1, 3]*
                                X\_{q - 1, r - 1, s - 1, t - 1}'*ρ/
                                  freq[\([3]\)]*\((1 - O*cf - 
                                    O*c*\((1 - freq[\([3]\)])\))\))\) /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)]; 
RM\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((X\_{m - 1, n - 1, o - 1, p - 1}'*X\_{q - 1, r - 1, s - 1, t - 1}'*\((1 - ρ)\))\) /. 
                          ModMat[\([\((n - 1)\) + \((p - 1)\) + 
                                1]\)];
]]]]]]]];\)\)

The total frequency of mated pairs composed of {m-1,n-1,o-1,p-1} mothers and {q-1,r-1,s-1,t-1} where these indices run from 1 to 2 is the sum contribution of assortatively mated pairs (AM) and randomly mated pairs (RM):

For[m = 1, 
        m ≤ 2, m++, 
For[n = 1, 
          n ≤ 2, n++, 
For[o = 1, 
            o ≤ 2, o++, 
For[p = 1, 
              p ≤ 2, p++, 
For[q = 1, 
                q ≤ 2, q++, 
For[r = 1, 
                  r ≤ 2, r++, 
For[s = 1, 
                    s ≤ 2, s++, 
For[t = 1, 
                      t ≤ 
                        2, t++, 
(Subscript[Y, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) = ((Subscript[AM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]) + 
                              (Subscript[RM, m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1]))/meanfertility]
]]]]]]];

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

To begin, we calculate the constant order terms in the association measures, assuming that the modifier has a weak effect.  This process confirms that only \(D\_{AM, AF}\) has a constant order term.

Assuming a weak modifier [Enter]

We assume that the modifier is weak, and we rewrite the assortment rules in terms of the average level of assortment initially, the change in assortment, and the dominance at the modifier locus:

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), 
            O*Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM])}] // Flatten

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

Calculations to constant order

toorder specifies the order to which we are calculating the association measures (here to constant order in O):

toorder = 0;

Note that we have to specify the order of the change in allele frequencies at the A and M locus.  We assume now {consistent with what follows in the next section} that neither the frequency of A nor the frequency of M changes to constant order (i.e., they change at a rate equal to or smaller than order O):

orderΔ(Subscript[P, A]) = 1;
orderΔ(Subscript[P, M]) = 1;

This allows us to write:

	(Subscript[P, M]) -> (Subscript[P, M]) + (O^order)Δ(Subscript[P, M])*Δ(Subscript[P, M]) /. 
        (Subscript[P, A]) -> (Subscript[P, A]) + (O^order)Δ(Subscript[P, A])*Δ(Subscript[P, A])
as	(Subscript[P, M]) -> (Subscript[P, M]) /. (Subscript[P, A]) -> (Subscript[P, A])

We verify below that, to this order, the following causes all of the changes in the association measures to equal zero (i.e., it is a valid QLE solution to this order):

\(\(subSTRONG = {D\_{AM, AF} -> D\_{AM, AF}, D\_{AM, MF} -> 0, 
          D\_{AM, MM} -> 0, D\_{AM, MM, AF, MF} -> 0, 
          D\_{AM, MM, MF} -> 0, D\_{AM, MM, AF} -> 0, 
          D\_{MM, MF} -> 0};\)\)

If the above is a valid QLE, then we can use the following simplified change of variables:

ChangeVarsSTRONG = ChangeVars /. subSTRONG

\(eqn\_{AM, MM} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

\(eqn\_{AM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

Only \(eqn\_{AM, AF}\) is non-zero, which allows us to solve for \(D\_{AM, AF}\).

\(eqn\_{AM, AF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, AF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

\(eqn\_{MM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {0, 1, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{MM, MF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

\(eqn\_{AM, MM, AF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, AF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

\(eqn\_{AM, MM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, MF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

\(eqn\_{AM, MM, AF, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, AF, MF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

The above has a simple solution when there is genotypic assortment (Equation 22):

\(\(Solve[eqn\_{AM, AF} == 0, D\_{AM, AF}] // Flatten\) // 
      Simplify\)

\(Factor[
      eqn\_{AM, AF} - \((\(-\ \((1 - aveρ)\)\)*D\_{AM, AF} + 
              aveρ \((freqAa/2)\)/2)\) /. 
        freqAa -> 2 \((1 - P\_A)\)\ P\_A - 2  D\_{AM, AF}]\)

Note that the change in \(D\_{AM, AF}\) given by \(eqn\_{AM, AF}\) can be written as \(\(-\((1 - aveρ)\)\)*D\_{AM, AF} + 
        aveρ \((freqAa/2)\)/2\).  The first term says that \(D\_{AM, AF}\)is destroyed to the extent that there is random mating.  The second term says that one round of assortative mating will create excess homozygosity by an amount freqAa/2 (half of the heterozygotes are converted into homozygotes, but recall that \(D\_{AM, AF}\)only measures half of the excess homozygosity (as defined), which accounts for the final 1/2.

The amount by which \(D\_{AM, AF}\) differs in the next generation from the constant order expectation of ((aveρ (1 - (Subscript[P, A])) (Subscript[P, A]))/(2 - aveρ)) is given by (\(eqn\_{AM, AF}\)+\(D\_{AM, AF}\)-((aveρ (1 - (Subscript[P, A])) (Subscript[P, A]))/(2 - aveρ)))

\(Factor[\((eqn\_{AM, AF} + 
          D\_{AM, AF} - \(aveρ\ \((1 - P\_A)\)\ P\_A\)\/\(2 - aveρ\))\)]\)

which is only ave(ρ/2) the distance that the system was in the previous generation (Equation 23):

\(Factor[%/\((D\_{AM, AF} - \(aveρ\ \((1 - P\_A)\)\ P\_A\)\/\(2 - aveρ\))\)]\)

Note that the change in \(D\_{AM, AF}\) given by \(eqn\_{AM, AF}\) can be written as \(\(-\((1 - aveρ)\)\)*D\_{AM, AF} + 
        aveρ \((freqAa/2)\)/2\).  The first term says that \(D\_{AM, AF}\)is destroyed to the extent that there is random mating.  The second term says that one round of assortative mating will create excess homozygosity by an amount freqAa/2 (half of the heterozygotes are converted into homozygotes, but recall that \(D\_{AM, AF}\)only measures half of the excess homozygosity (as defined), which accounts for the final 1/2.

This confirms that the QLE values are correct when there is genotypic assortment

\(\(subD = {D\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\), D\_{AM, MF} -> 0, D\_{AM, MM} -> 0, 
          D\_{AM, MM, AF, MF} -> 0, D\_{AM, MM, MF} -> 0, 
          D\_{AM, MM, AF} -> 0, D\_{MM, MF} -> 0};\)\)

\(\({eqn\_{AM, AF}, eqn\_{MM, MF}, eqn\_{AM, MM}, eqn\_{AM, MF}, 
            eqn\_{AM, MM, AF}, eqn\_{AM, MM, MF}, eqn\_{AM, MM, AF, MF}} /. 
          subD\) /. h2 -> 1 // Simplify\)

Calculations to linear order in O

Now we allow the existence of the next order terms in the association measures:

\(\(SubDSmall = {D\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\) + O*D1\_{AM, AF}, D\_{MM, MF} -> O*D1\_{MM, MF}, 
          D\_{AM, MM} -> O*D1\_{AM, MM}, 
          D\_{AM, MF} -> O*D1\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D1\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D1\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D1\_{AM, MM, AF, MF}};\)\)

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination change the frequency of A in the grouping model when there are already substantial departures from HW:

\(ΔPR\_A = 
      Collect[Normal[
          Series[\((\(P\_A' - P\_A /. SubDSmall\) /. subTrans)\), {O, 0, 
              1}]], {c, cf, D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
          D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
          D1\_{AM, MM, AF, MF}}, Factor]\)

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination do not change the frequency of M in the grouping model either:

\(ΔPR\_M = 
      O*Collect[
          D[\((\(P\_M' - P\_M /. SubDSmall\) /. subTrans)\), {O, 1}] /. 
            O -> 0, {c, cf, D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

The overall change in the allele frequency, including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1:

Δ(Subscript[P, A]) = 
        O (1 - 
                (Subscript[P, A])) (Subscript[P, A]) ((Subscript[P, A]) ((Subscript[S, AA])[(Subscript[P, A])] - 
                      (Subscript[S, Aa])[(Subscript[P, A])]) + (1 - (Subscript[P, A])) ((Subscript[S, Aa])[(Subscript[P, A])] - 
                      (Subscript[S, aa])[(Subscript[P, A])])) - 
          O ((aveρ (Subscript[P, A]) (1 - (Subscript[P, A])))/(2 - 
                  aveρ)) ((1 - (Subscript[P, A]))  ((Subscript[S, AA])[(Subscript[P, A])] - 
                      (Subscript[S, Aa])[(Subscript[P, A])]) + 
                (Subscript[P, A]) ((Subscript[S, Aa])[(Subscript[P, A])] - 
                      (Subscript[S, aa])[(Subscript[P, A])])) + Δ(Subscript[PR, A]);

     Δ(Subscript[P, M]) = 0;

To order (O^2), the costs of non-random mating do change the frequency of M: [Note that taking the Taylor series "manually" via the double derivative is much faster]

\(ΔPR2\_M = 
      O\^2\/2*Collect[
          D[\((\(P\_M' - P\_M /. SubDSmall\) /. subTrans)\), {O, 2}] /. 
            O -> 0, {c, cf, D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

\(\(ΔP2\_M = 
        O\^2\ \((D1\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
                      S\_AA[P\_A])\) + 
                D1\_{AM, MF}\ \((\((\(-1\) + P\_A)\)\ S\_aa[
                          P\_A] + \((1 - 2\ P\_A)\)\ S\_Aa[P\_A] + 
                      P\_A\ S\_AA[P\_A])\) + 
                D1\_{AM, MM}\ \((\((\(-1\) + P\_A)\)\ S\_aa[
                          P\_A] + \((1 - 2\ P\_A)\)\ S\_Aa[P\_A] + 
                      P\_A\ S\_AA[
                          P\_A])\))\) + ΔPR2\_M;\)\)

\(eqn\_{AM, MM} = 
      O*Collect[
          D[\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                        0}] /. {P\_AM -> P\_A, 
                                      P\_AF -> P\_A, P\_MM -> P\_M, 
                                      P\_MF -> P\_M}\) /. 
                                  P\_M -> P\_M + ΔP\_M\) /. 
                                P\_A -> P\_A + ΔP\_A\) /. 
                              subnextgen)\) - D\_{AM, MM})\) /. ChangeVars\) /. 
                    SimpleSubs\) /. SubDSmall\) /. subTrans, O] /. 
            O -> 0, {D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MF} = 
      O*Collect[
          D[\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                        1}] /. {P\_AM -> P\_A, 
                                      P\_AF -> P\_A, P\_MM -> P\_M, 
                                      P\_MF -> P\_M}\) /. 
                                  P\_M -> P\_M + ΔP\_M\) /. 
                                P\_A -> P\_A + ΔP\_A\) /. 
                              subnextgen)\) - D\_{AM, MF})\) /. ChangeVars\) /. 
                    SimpleSubs\) /. SubDSmall\) /. subTrans, O] /. 
            O -> 0, {D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{MM, MF} = 
      O*Collect[
          D[\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {0, 1, 0, 
                                        1}] /. {P\_AM -> P\_A, 
                                      P\_AF -> P\_A, P\_MM -> P\_M, 
                                      P\_MF -> P\_M}\) /. 
                                  P\_M -> P\_M + ΔP\_M\) /. 
                                P\_A -> P\_A + ΔP\_A\) /. 
                              subnextgen)\) - D\_{MM, MF})\) /. ChangeVars\) /. 
                    SimpleSubs\) /. SubDSmall\) /. subTrans, O] /. 
            O -> 0, {D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MM, AF} = 
      O*Collect[
          D[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                        0}] /. {P\_AM -> P\_A, 
                                        P\_AF -> P\_A, 
                                        P\_MM -> P\_M, 
                                        P\_MF -> P\_M}\) /. 
                                    P\_M -> P\_M + ΔP\_M\) /. 
                                  P\_A -> P\_A + ΔP\_A\) /. 
                                subnextgen\) /. h2 -> 1)\) - 
                          D\_{AM, MM, AF})\) /. ChangeVars\) /. SimpleSubs\) /. 
                  SubDSmall\) /. subTrans, O] /. O -> 0, {D1\_{AM, AF}, 
            D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
            D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

\(O*Collect[
        D[\(\(\(\((\((\(\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                        0}] /. {P\_AM -> P\_A, 
                                        P\_AF -> P\_A, 
                                        P\_MM -> P\_M, 
                                        P\_MF -> P\_M}\) /. 
                                    P\_M -> P\_M + ΔP\_M\) /. 
                                  P\_A -> 
                                    P\_A + ΔP\_A\) /. {D1\_{AM, MM} -> 0, D1\_{AM, MF} -> 0}\) /. subnextgen\) /. h2 -> 1)\) - 
                        D\_{AM, MM, AF})\) /. ChangeVars\) /. SimpleSubs\) /. 
                SubDSmall\) /. subTrans, O] /. O -> 0, {D1\_{AM, AF}, 
          D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
          D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
              eqn\_{AM, MM, AF} == 0}, {D1\_{AM, MM}, D1\_{AM, MF}, 
              D1\_{AM, MM, AF}}] // Simplify\) // Flatten\)

If interested in the average level of homozygosity at QLE:

\(eqn\_{AM, AF} = 
      O*Collect[
          D[\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                        0}] /. {P\_AM -> P\_A, 
                                      P\_AF -> P\_A, P\_MM -> P\_M, 
                                      P\_MF -> P\_M}\) /. 
                                  P\_M -> P\_M + ΔP\_M\) /. 
                                P\_A -> P\_A + ΔP\_A\) /. 
                              subnextgen)\) - D\_{AM, AF})\) /. ChangeVars\) /. 
                    SimpleSubs\) /. SubDSmall\) /. subTrans, O] /. 
            O -> 0, {D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, 
            D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
            D1\_{AM, MM, AF, MF}}, Factor]\)

\(Solve[% == 0, D1\_{AM, AF}] // Simplify\)

finalΔ(Subscript[P2, M]) = 
      Collect[Δ(Subscript[P2, M]) /. subQLE, {cf, c}, Factor]

Note that the cost is related to the change in rarity of mates experienced by the change in the modifier.

When assortative mating is common, the modifier affects both the tendency to mate within groups and \(D\_{AM, AF}\).  First, we hold \(D\_{AM, AF}\) constant and look at changes in the difficulty of finding a mate:

\(rarity = 
      Factor[\(\(\(ρ*FreqGroup1*\((1 - FreqGroup1)\) + ρ*
                    FreqGroup2*\((1 - FreqGroup2)\) + ρ*
                    FreqGroup3*\((1 - FreqGroup3)\) /. 
                FreqGroup1 -> \((\((1 - P\_A)\)\^2 + D\_{AM, AF})\)\) /. 
              FreqGroup2 -> \((2 \( P\_A\) \((1 - P\_A)\) - 
                    2\ D\_{AM, AF})\)\) /. 
            FreqGroup3 -> \((P\_A\^2 + D\_{AM, AF})\)\) /. ρ -> 
            aveρ]\)

Factor[
      Normal[Series[(rarity /. 
                aveρ -> 
                  aveρ + 
                    O*Δρ) - (rarity /. ρ -> 
                  aveρ), {O, 0, 1}]]]

or equivalently:

Factor[
      Normal[Series[(Subscript[P, M]) ((rarity /. 
                        aveρ -> (Subscript[ρ, MM])) - (rarity /. 
                        aveρ -> (Subscript[ρ, Mm]))) + (1 - 
                    (Subscript[P, M])) ((rarity /. 
                        aveρ -> (Subscript[ρ, Mm])) - (rarity /. 
                        aveρ -> (Subscript[ρ, mm]))) /. subTrans, {O, 
            0, 1}]]]

Δrarity1 = 
      Factor[Normal[Series[% /. SubDSmall, {O, 0, 1}]]]

In addition to the direct change in rarity felt by females as they mate more often in groups, there is a secondary change caused by altering male group structure experienced by those females who are already assortatively mating (the following are multiplied by 1/2, because it is only the change in male group structure that affects the costs experienced by females;  changes in female group structure don't affect males):

\(1/2*
      Factor[\(\(\(\(Normal[
                    Series[\((rarity /. 
                            D\_{AM, AF} -> 
                              D\_{AM, AF} + 
                                O*D1\_{AM, MM, AF})\) - \((rarity /. 
                            D\_{AM, AF} -> 
                              D\_{AM, AF} - O*D1\_{AM, MM, AF})\), {O, 0, 
                        1}]] /. aveρ -> ρ\) /. subQLE\) /. 
              SubDSmall\) /. D1\_{AM, AF} -> 0\) /. ρ -> 
            aveρ]\)

or equivalently:

\(Δrarity2 = 
      1/2*Factor[
          Normal[Series[\(P\_M\) \((\((rarity /. 
                            D\_{AM, AF} -> \(ρ\_MM\ \((1 - P\_A)\)\ P\_A\)\/\(2 - ρ\_MM\))\) - \((rarity /. 
                            D\_{AM, AF} -> \(ρ\_Mm\ \((1 - P\_A)\)\ P\_A\)\/\(2 - ρ\_Mm\))\))\) + \((1 - 
                        P\_M)\) \((\((rarity /. 
                            D\_{AM, AF} -> \(ρ\_Mm\ \((1 - P\_A)\)\ P\_A\)\/\(2 - ρ\_Mm\))\) - \((rarity /. 
                            D\_{AM, AF} -> \(ρ\_mm\ \((1 - P\_A)\)\ P\_A\)\/\(2 - ρ\_mm\))\))\) /. subTrans, {O, 0, 1}]]]\)

The overall change in the rarity of males can be written as:

ChangeInRarity = 
      Factor[Δrarity1 + Δrarity2]

Besides the cost, the main term in finalΔ(Subscript[P2, M]) measures the efficacy of assortative mating in associating a modifier with homozygotes:

\(O\ D1\_{AM, MM, AF} /. subQLE\)

This term is again described by equation (10) with \(ΔD\_{AM, AF}\)given by:

Dterm =  ((aveρ (Subscript[P, A]) (1 - (Subscript[P, A])))/(2 - aveρ)) /. 
          aveρ -> ρ;
\(ΔD\_{AM, AF} = 
      Factor[Normal[
          Series[\((\((\(P\_M\) 
                          Dterm /. {ρ -> ρ\_MM\ })\) + \((\((1 - 
                              P\_M)\) 
                          Dterm /. {ρ -> ρ\_Mm\ })\))\) - \((\((\(P\_M\) Dterm /. {ρ -> ρ\_Mm\ })\) + \((\((1 - P\_M)\) 
                          Dterm /. {ρ -> ρ\_mm\ })\))\) /. 
              subTrans, {O, 0, 1}]]]\)

\(Factor[\(\(\((1 - P\_M)\)\ P\_M\)\/2\) ΔD\_{AM, AF} - 
          O\ D1\_{AM, MM, AF} /. subQLE]\)

We can also relate \(D1\_{AM, MM, AF}\) to the single generation efficiency of assortment in producing homozygotes, θ:

\(\(FreqAA = P\_A\%2 + D0\_{AM, AF};\)\)
\(\(FreqAa = 
        2 \((1 - P\_A)\)\ P\_A - 
          2  D0\_{AM, AF};\)\)
\(\(Freqaa = \((1 - P\_A)\)\^2\  + D0\_{AM, AF};\)\)

\(θ = 
      Factor[\(\(\(\(1\/2\) \((\((FreqAa*group[2, 1])\)\^2\/FreqGroup1 + \((FreqAa*group[2, 2])\)\^2\/FreqGroup2 + \((FreqAa*group[2, 3])\)\^2\/FreqGroup3)\) - 
                  2 \((\(\((Freqaa*group[1, 1])\) \((FreqAA*group[3, 1])\)\)\/FreqGroup1 + \(\((Freqaa*group[1, 2])\) \((FreqAA*group[3, 2])\)\)\/FreqGroup2 + \(\((Freqaa*group[1, 3])\) \((FreqAA*group[3, 3])\)\)\/FreqGroup3)\) /. 
                FreqGroup1 -> 
                  group[1, 1]*Freqaa + group[2, 1]*\ FreqAa + 
                    group[3, 1]*\ FreqAA\) /. 
              FreqGroup2 -> 
                group[1, 2]*Freqaa + group[2, 2]*\ FreqAa + 
                  group[3, 2]*\ FreqAA\) /. 
            FreqGroup3 -> 
              group[1, 3]*Freqaa + group[2, 3]*\ FreqAa + 
                group[3, 3]*\ FreqAA\) /. 
          D0\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\)]\)

This is consistent with the QLE result if Δθ has the following form:

\(Factor[\(\(\(\((1 - 
                        P\_M)\)\ P\_M\)\/2\) \((Δθ\/2)\) - O\ D1\_{AM, MM, AF} /. Δθ -> \(O\ Δρ\ θ\)\/\(\((1 - aveρ/2)\) \((1 - aveρ)\)\)\) /. subQLE]\)

Why Δθ should have this form is less obvious, but I think can be explained as follows.

A modifier that increases assortative mating again has two effects.  The first is that it directly increases excess homozygosity in a generation by an amount:

O Δρ θ

The excess homozygotes produced by the modifier in the current generation will then persist for longer because of the assortment already prevalent within the population.  On average, we expect a departure from QLE to persist for 1/(1-aveρ/2) generations [see previous section, which showed that the departure from QLE decays at rate aveρ/2, so the probability that it persists is 1-aveρ/2 per generation, or on average 1/(1-aveρ/2) until decay]:

part1 = %/(1 - aveρ/2) // Factor

In addition, the modifier also acts in the current generation to protect excess homozygosity, because these homozygous individuls would otherwise have entered the random mating pool.  Recalling that the total excess homozygosity is \(D0\_{AM, AF}\), this protective effect equals:

\(O\ Δρ\ \((2  D0\_{AM, AF})\) /. 
        D0\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\) // Factor\)

Again we expect this departure from QLE caused by the modifier to persist for 1/(1-aveρ/2) generation

part2 = %/(1 - aveρ/2) // Factor

These parts sum to give us a result of the form Δθ:

Factor[(part1 + 
              part2) - Δθ /. Δθ -> ((O Δρ θ)/((1 - aveρ/2) (1 - aveρ)))]

Furthermore, it does reduce to O Δρ θ when assortative mating is absent, in which case departures from HW do not persist and there is no excess homozygosity to be preserved:

(part1 + part2) - O Δρ θ /. 
        aveρ -> 0 // Factor

Overall, the QLE change in the modifier can be written as:

\(\(\(-\(1\/2\)\)\ cf\ O\^2\ Δρ\ \((1 - 
                P\_M)\)\ P\_M - \ 
          1\/2\ c\ \ O\ \((1 - P\_M)\)\ P\_M\ ChangeInRarity\  + 
          O\^2\ \ D1\_{AM, MM, AF}\ \ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
                S\_AA[P\_A])\)\  /. 
        subQLE;\)
\)
% - finalΔ(Subscript[P2, M]) // Factor

Or in terms of Δθ:

\(\(\(\(-\(1\/2\)\)\ cf\ O\^2\ Δρ\ \((1 - 
                  P\_M)\)\ P\_M - \ 
            1\/2\ c\ \ O\ \ \((1 - P\_M)\)\ P\_M\ ChangeInRarity\  + 
            O \(\(\((1 - 
                        P\_M)\)\ P\_M\)\/2\) \(Δθ\/2\) \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + 
                  S\_AA[P\_A])\) /. Δθ -> \(O\ Δρ\ θ\)\/\(\((1 - aveρ/2)\) \((1 - aveρ)\)\)\) /. 
        D\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\);\)
\)
% - finalΔ(Subscript[P2, M]) // Factor

\(D1\_{AM, MM, AF}\)increases with increasing assortment, so the modifier becomes more strongly associated with homozygosity as assortative mating increases:, implying that the selection favoring the modifier will become more efficient as homozygosity increases

Plot[(4/(((2 - aveρ))^2)), {aveρ, 0, 1}, 
      PlotRange -> {Automatic, {0, 5}}]

Our result is similar, but not identical, to that obtained by Endler (1970) based on assuming no associations other than departures from HW at the A locus:

Clear[m]

\(\(\(\(\(\(\(finalΔP2\_M/\((O \((S\_aa[P\_A] - 
                              2\ S\_Aa[P\_A] + S\_AA[P\_A])\))\) /. 
                    c -> 0\) /. cf -> 0\) /. 
                D0\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\)\) /. Δρ -> \((P\_M\ \((\ ρ\_MM - ρ\_Mm)\) + \((1 - 
                          P\_M)\)\ \((\ ρ\_Mm - ρ\_mm)\))\)\) /. ρ\_mm -> 0\) /. ρ\_Mm -> \ m\) /. ρ\_MM -> \ m // 
      Factor\)

\(\(\(\(\(\(O\ m\ Y\ \((\ \(P\_A\) \((1 - P\_A)\) - FreqAa/4)\) /. 
                  Y -> \((1 - P\_M)\)\^2\) /. 
                D0\_{AM, AF} -> \(aveρ\ \(P\_A\) \((1 - P\_A)\)\)\/\(2 - aveρ\)\) /. Δρ -> \((P\_M\ \((\ ρ\_MM - ρ\_Mm)\) + \((1 - 
                          P\_M)\)\ \((\ ρ\_Mm - ρ\_mm)\))\)\) /. ρ\_mm -> 0\) /. ρ\_Mm -> m\) /. ρ\_MM -> m // 
      Factor\)

%/%% // Factor

The only two differences caused by allowing assortative mating at a higher order is the factor (1/((1 - aveρ/2) (1 - aveρ))) in the production of excess homozygosity (Δθ), which indicates that the more assortative mating there is, the stronger the selection for more assortative mating, plus rarity is changed by the fact that there are fewer heterozygotes.

Factor[
      D[ChangeInRarity/( O Δρ), 
        aveρ]]
Plot3D[%, {(Subscript[P, A]), 0, 1}, {aveρ, 0, 1}, 
      PlotRange -> {Automatic, Automatic, {0.2, -0.5}}]

Increasing the degree of assortative mating may make it easier or harder to find a mate.  It tends to make it easier when one of the alleles is rare (because assortment causes the most common homozygotes to become even more common and causes the relatively rare heterozygotes to become even rarer).   But it tends to make it harder to find a mate when (Subscript[P, A]) is near 1/2 and aveρ is near zero because a little bit of assortment tends to cause the groups to become more equal in frequency.

If (Subscript[H, ns]) were to remain constant, than we can ask if there might be an ESS as the level of assortment rises (i.e., if the costs rise faster than the benefits).  It turns out that the answer is no, because we can write

finalΔ(Subscript[P2, M]) /. ((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + 
              (Subscript[S, AA])[(Subscript[P, A])])  -> (Subscript[H, ns]) // Factor

as

(( (O^2) Δρ (1 - 
                      (Subscript[P, M])) (Subscript[P, M]))/( 4 (((1 - aveρ/2))^2)))(((Subscript[H, ns]) (1 - (Subscript[P, A])) (Subscript[P, A]) - 
                      4 c (1 - (Subscript[P, A])) (Subscript[P, A]) (2 - 3 (Subscript[P, A]) + 
                            3 (Subscript[P, A]^2)) - 2 cf)+ave(ρ/((1 - aveρ/2))) ((1 - 
                              aveρ/2) (2 - 
                              aveρ/2)  cf  + (1 - 
                              (Subscript[P, A])) (Subscript[P, A]) c (2 (1 - ave(ρ/2)) + 
                              6 (1 - (Subscript[P, A])) (Subscript[P, A]) + 
                              6 (((1 - 
                                        ave(ρ/2)))^2) (((1 - 2 (Subscript[P, A])))^2) + 3 (1 - ave(ρ/2)) (((1 - 2 (Subscript[P, A])))^2))))-finalΔ(Subscript[P2, M])/.((Subscript[S, aa])[(Subscript[P, A])] - 2 (Subscript[S, Aa])[(Subscript[P, A])] + (Subscript[S, AA])[(Subscript[P, A])])  -> 
          (Subscript[H, ns])//Factor

If this is positive when aveρ = 0 (the first blue term is positive), then it remains positive as aveρ increases (holding (Subscript[H, ns]) constant), because the magenta term is positive.  Thus, the indirect advantages of assortment increase faster than the costs as aveρ rises.

PREFERENCE-BASED MODEL
-> Assumes  (Subscript[P, A]) ~ 1/2
-> No costs

For mating only

In this second phase, we account for the effects of mating and recombination on the allele frequencies and association measures.  We first account for the fact that at the census and following natural selection, there is no difference in frequency between genotypes {i,j,k,l} and {k,l,i,j}:

Genotype frequencies

\(\(X\_{0, 0, 0, 0}' = 
        X\_{0, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = 
        X\_{0, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = 
        X\_{0, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = 
        X\_{0, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = 
        X\_{1, 0, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = 
        X\_{0, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = 
        X\_{0, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = 
        X\_{1, 0, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = 
        X\_{0, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = 
        X\_{1, 1, 0, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = 
        X\_{1, 0, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = 
        X\_{0, 1, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = 
        X\_{1, 1, 1, 0} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = 
        X\_{1, 0, 1, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = 
        X\_{1, 1, 0, 1} /. SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = 
        X\_{1, 1, 1, 1} /. SimpleSubs // Factor;\)\)

Assortative mating

Assume that assortative mating depends on the "A" (or i,k or m,o or q,s) locus which is also responsible for coevolution

The following preference matrix contains female preferences, with female genotypes at the A locus in rows and male genotypes in columns.

We assume that females have dislikes:
	* for males differing by no alleles (δ)  [allows for disassortative mating]
	* for males differing by one allele (κ).
	* for males differing by two alleles (ρ).

MatrixForm[
      MateMat = {{1 - δ, 1 - κ, 1 - ρ}, {1 - κ, 
            1 - δ, 1 - κ}, {1 - ρ, 1 - κ, 
            1 - δ}}]

Only the female's modifier status affects the strength of preference:

ModMat = {{δ -> (Subscript[δ, mm]), κ -> (Subscript[κ, mm]), ρ -> (Subscript[ρ, mm])}, {δ -> (Subscript[δ, Mm]), ρ -> (Subscript[ρ, Mm]), κ -> (Subscript[κ, Mm])}, {δ -> (Subscript[δ, MM]), κ -> (Subscript[κ, MM]), ρ -> (Subscript[ρ, MM])}};

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

Define fitness of mated pairs

In the function below, female genome is given by {m,n,o,p} and male genome by {q,r,s,t} where letters take values 0 or 1 depending on allelic status at that position in the genome.

WMate[m_, n_, o_, p_, q_, r_, s_, t_] := 
        MateMat[[m + o + 1, q + s + 1]] /. 
          ModMat[[n + p + 1]];

Normalize WMate so that all females are mated

\(For[m = 1, 
      m ≤ 2, \(m++\), 
For[n = 1, 
        n ≤ 2, \(n++\), 
For[o = 1, 
          o ≤ 2, \(o++\), 
For[p = 1, 
            p ≤ 2, \(p++\), 
            NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 0]]]]\)

\(\(\(
\)\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 
                        NormalFemale\_{m - 1, n - 1, o - 1, p - 1} + 
                          X\_{q - 1, r - 1, s - 1, t - 1}' 
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]]]]]]]]];\)\(
\)
    \)\)\)

Because of the length of time to complete the calculations, the following was considered only without a cost of mating preference (see the code with weak assortative mating to add back in the cost).

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, 
                          t - 1] = 
                        WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                            s - 1, t - 1]/
                          NormalFemale\_{m - 1, n - 1, o - 1, p - 1}]]]]]]]];\)\)

Calculate the mean fitness of the population

\(\(M\&_ = 0;\)\)
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      M\&_ = M\&_ + 
                          X\_{m - 1, n - 1, o - 1, p - 1}'*
                            X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]]]]]]]]];\)\)
\(M\&_ = Factor[M\&_ /. ChangeVars]\)

Calculate frequencies of mated pairs

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = \((X\_{m - 1, n - 1, o - 1, p - 1}'*X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1])\)]]]]]]]];\)\)

Recombination and Offspring Formation

Calculate frequencies of haploid gametes with genotype i,j produced by a diploid with paternal genoype k,l and maternal genotype m,n

Read the below as haploid gamete with genotype i, j  produced by diploid genotype with paternal chromosome k,l and maternal chromosome m,n
Offspring={i,j}
Paternal={k,l}
Maternal={m,n}

Gamete[i_, j_, k_, l_, m_, n_] := (OffProd = 1; 
        If[i ≠ k && i ≠ m, 
          OffProd = OffProd*0]; 
If[
          i == m && i == k, ChromString = Either]; 
        If[i == m && i ≠ k, OffProd = OffProd*1/2; 
          ChromString = Maternal]; 
        If[i == k && i ≠ m, OffProd = OffProd*1/2; 
          ChromString = Paternal]; 
If[
          j == l && j == n, 
          OffProd = OffProd*1]; 
If[
          j ≠  l && j ≠ n, OffProd = OffProd*0]; 
        If[j == l && j ≠ n && ChromString == Paternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Maternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Paternal, 
          OffProd = OffProd*rec]; 
If[
          j == n && j ≠ l && ChromString == Maternal, 
          OffProd = OffProd*(1 - rec)]; 
If[
          j == l && j ≠ n && ChromString == Either, 
          OffProd = OffProd*1/2]; 
If[
          j == n && j ≠ l && ChromString == Either, 
          OffProd = OffProd*1/2]; 
Return[
          OffProd])

Now use this to calculate the frequency of diploid genotype (Subscript[i, m]) (Subscript[j, m])(Subscript[k, f])(Subscript[l, f]) from a mating of diploid maternal genotype  (Subscript[m, m]) (Subscript[n, m])(Subscript[o, f])(Subscript[p, f]) and  diploid paternal genotype (Subscript[q, m]) (Subscript[r, m])(Subscript[s, f])(Subscript[t, f])

Babies[i_, j_, k_, l_, m_, n_, o_, p_, q_, r_, s_, t_] := 
        Return[Gamete[i, j, m, n, o, p]*
            Gamete[k, l, q, r, s, t]];

Now calculate the frequencies of diploid genotypes after recombination and segregation

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]
\(For[i = 1, i ≤ 2, \(i++\), 
      For[j = 1, j ≤ 2, \(j++\), 
        For[k = 1, k ≤ 2, \(k++\), 
          For[l = 1, l ≤ 2, \(l++\), 
            For[m = 1, m ≤ 2, \(m++\), 
              For[n = 1, n ≤ 2, \(n++\), 
                For[o = 1, o ≤ 2, \(o++\), 
                  For[p = 1, p ≤ 2, \(p++\), 
                    For[q = 1, q ≤ 2, \(q++\), 
                      For[r = 1, r ≤ 2, \(r++\), 
                        For[s = 1, s ≤ 2, \(s++\), 
                          For[t = 1, t ≤ 2, \(t++\), 
                            X\_{i - 1, j - 1, k - 1, l - 1}'' = 
                              X\_{i - 1, j - 1, k - 1, l - 1}'' + 
                                Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)*\ Babies[i - 1, j - 1, k - 1, l - 1, m - 1, n - 1, o - 1, 
                                    p - 1, q - 1, r - 1, s - 1, 
                                    t - 1]]]]]]]]]]]]]\)

Randomize chromosomes from mother/father

Non-random mating can cause offspring with chromosome i from the mother and j from the father to differ in frequency from offspring with chromosome i from the father and j from the mother.  But because sex-of-origin does not affect natural selection or mating in this study, we next set genotypes ij and ji to the average of these two frequencies for all diploid genotypes where i≠j:

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

QLE analysis

To begin, we calculate the constant order terms in the association measures, assuming that the modifier has a weak effect.  This process confirms that only \(D\_{AM, AF}\) has a constant order term.

Assuming a weak modifier [Enter]

We assume that the modifier is weak, and we rewrite the assortment rules in terms of the average level of assortment initially, the change in assortment, and the dominance at the modifier locus:

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), 
            O*Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm])), ( (Subscript[δ, Mm]) - (Subscript[δ, mm])) == hδ*( (Subscript[δ, MM]) - (Subscript[δ, mm])), 
            O*Δδ == ((Subscript[P, M]) ( (Subscript[δ, MM]) - (Subscript[δ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[δ, Mm]) - (Subscript[δ, mm]))), 
aveδ == ((Subscript[P, M]^2) (Subscript[δ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[δ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[δ, mm])), ( (Subscript[κ, Mm]) - (Subscript[κ, mm])) == hκ*( (Subscript[κ, MM]) - (Subscript[κ, mm])), 
            O*Δκ == ((Subscript[P, M]) ( (Subscript[κ, MM]) - (Subscript[κ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[κ, Mm]) - (Subscript[κ, mm]))), 
aveκ == ((Subscript[P, M]^2) (Subscript[κ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[κ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[κ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), (Subscript[δ, mm]), (Subscript[δ, Mm]), (Subscript[δ, MM]), (Subscript[κ, mm]), (Subscript[κ, Mm]), (Subscript[κ, MM])}] // Flatten

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

Calculations to constant order

toorder specifies the order to which we are calculating the association measures (here to constant order in O):

toorder = 0;

Note that we have to specify the order of the change in allele frequencies at the A and M locus.  We assume now {consistent with what follows in the next section} that neither the frequency of A nor the frequency of M changes to constant order (i.e., they change at a rate equal to or smaller than order O):

orderΔ(Subscript[P, A]) = 1;
orderΔ(Subscript[P, M]) = 1;

This allows us to write:

	(Subscript[P, M]) -> (Subscript[P, M]) + (O^order)Δ(Subscript[P, M])*Δ(Subscript[P, M]) /. 
        (Subscript[P, A]) -> (Subscript[P, A]) + (O^order)Δ(Subscript[P, A])*Δ(Subscript[P, A])
as	(Subscript[P, M]) -> (Subscript[P, M]) /. (Subscript[P, A]) -> (Subscript[P, A])

Below we derive the QLE values for the association measures to constant order.

(Be careful: even though we assume that maternal/paternal chromosomes are immaterial (e.g., \(X\_{0, 0, 1, 0}\)acts like \(X\_{1, 0, 0, 0}\)), it is not the case that they are equal in frequency at the end of the life cycle ((\(X\_{0, 0, 1, 0}\))''≠(\(X\_{1, 0, 0, 0}\))'').  Thus, do not make the SimpleSubs substitution at the end of the life cycle, only at the beginning.  Effectively, we add another stage in the life cycle where we set \(X\_{0, 0, 1, 0}''\) and \(X\_{1, 0, 0, 0}''\)to their average, as the subsequent generation only depends on their average (or their sum).)

We use the fact that previous analyses (see StrongAssortmentWeakModifier.nb) showed a QLE solution of the following form, where we must still solve for \(D\_{AM, AF}\):

\(subSTRONG = {D\_{AM, AF} -> D\_{AM, AF}, D\_{AM, MF} -> 0, 
        D\_{AM, MM} -> 0, D\_{AM, MM, AF, MF} -> 0, 
        D\_{AM, MM, MF} -> 0, D\_{AM, MM, AF} -> 0, 
        D\_{MM, MF} -> 0}\)

If the above is a valid QLE, then we can use the following simplified change of variables:

ChangeVarsSTRONG = ChangeVars /. subSTRONG

\(eqn\_{AM, MM} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

\(eqn\_{AM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

Only \(eqn\_{AM, AF}\) is non-zero, but it cannot be easily solved for \(D\_{AM, AF}\) or for aveρ:

\(eqn\_{AM, AF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, AF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

The solution simplifies when (Subscript[P, A]) = 1/2 into a form that can be solved for aveρ:

\(eqn\_{AM, AF} /. P\_A -> 1/2 // Factor\)

The following describes the relationship between aveρ and \(D\_{AM, AF}\) to leading order in O:

Solve[% == 0, aveρ] // Simplify // Flatten

\(eqn\_{MM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {0, 1, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{MM, MF})\) /. subTrans\) /. 
              SimpleSubs\) /. O -> 0\) /. subSTRONG]\)

\(eqn\_{AM, MM, AF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    0}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, AF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

\(eqn\_{AM, MM, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, MF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

\(eqn\_{AM, MM, AF, MF} = 
      Factor[\(\(\(\((\((\(\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                    1}] /. {P\_AM -> P\_A, 
                                  P\_AF -> P\_A, P\_MM -> P\_M, 
                                  P\_MF -> P\_M}\) /. P\_M -> P\_M\) /. 
                            P\_A -> P\_A\) /. subnextgen\) /. 
                        ChangeVarsSTRONG)\) - D\_{AM, MM, AF, MF})\) /. 
                subTrans\) /. SimpleSubs\) /. O -> 0\) /. 
          subSTRONG]\)

Calculations to linear order in O (assumes  (Subscript[P, A]) ~ 1/2)

Derivations

(Subscript[P, A]) = 1/2 - O*less;

Now we allow the existence of the next order terms in the association measures:

\(\(SubDSmall = {D\_{AM, AF} -> D0\_{AM, AF} + O*D1\_{AM, AF}, 
          D\_{MM, MF} -> O*D1\_{MM, MF}, 
          D\_{AM, MM} -> O*D1\_{AM, MM}, 
          D\_{AM, MF} -> O*D1\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D1\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D1\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D1\_{AM, MM, AF, MF}};\)\)

\(\(subρ = {aveρ -> \(aveδ - 16\ \((\(-2\) + aveκ)\)\ D0\_{AM, AF} - 16\ \((aveδ - 4\ aveκ)\)\ D0\_\({AM, AF}\)\%2\)\/\(1 + 16\ D0\_{AM, AF} + 48\ D0\_\({AM, AF}\)\%2\)};\)\)

(Subscript[P, A])' = PfromX[{i, j, k, l}, {1, 0, 1, 0}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination change the frequency of A in the preference-based model:

\(ΔPR\_A = 
      Collect[Normal[
          Series[\((\(\(P\_A' - P\_A /. SubDSmall\) /. subTrans\) /. 
                subρ)\), {O, 0, 1}]], {D1\_{AM, AF}, D1\_{MM, MF}, 
          D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
          D1\_{AM, MM, AF, MF}}, Factor]\)

(Subscript[P, M])' = PfromX[{i, j, k, l}, {0, 1, 0, 1}] /. subnextgen /. 
          ChangeVars;

To order O, mating and recombination also change the frequency of M in the preference-based model:

\(ΔPR\_M = 
      Collect[Normal[
          Series[\((\(\(P\_M' - P\_M /. SubDSmall\) /. subTrans\) /. 
                subρ)\), {O, 0, 1}]], {D1\_{AM, AF}, D1\_{MM, MF}, 
          D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
          D1\_{AM, MM, AF, MF}}, Factor]\)

The above is easier to interpret without using the leading order relationship given by subρ:

\(ΔPR\_M = 
      Collect[Normal[
          Series[\((\(P\_M' - P\_M /. SubDSmall\) /. subTrans)\), {O, 0, 
              1}]], {D1\_{AM, AF}, D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, 
          D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, 
        Factor]\)

\(\(\(\ \)\(\(ΔP\_A = 
        O\ \((1 - 
                P\_A)\)\ P\_A\ \((\(-\((1 - P\_A)\)\)\ S\_aa[
                    P\_A] + \((1 - 2\ P\_A)\)\ S\_Aa[P\_A] + 
                P\_A\ S\_AA[P\_A])\) - 
          O\ D0\_{AM, AF}\ \((P\_A\ S\_aa[P\_A] + S\_Aa[P\_A] - 
                2\ P\_A\ S\_Aa[P\_A] - S\_AA[P\_A] + 
                P\_A\ S\_AA[
                    P\_A])\) + ΔPR\_A;\)

    \ \(ΔP\_M = ΔPR\_M;\)\)\)\)

The following second order terms were calculated, but they are not needed (the leading order term is order O).

\(ΔPR2\_M = 
      Collect[Normal[
          Series[\((\(\(P\_M' - P\_M /. SubDSmall\) /. subTrans\) /. 
                subρ)\), {O, 0, 2}]], {D1\_{AM, AF}, D1\_{MM, MF}, 
          D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
          D1\_{AM, MM, AF, MF}}, Factor]\)

The QLE association measure giving the overall change in the modifier to order (O^2), including the change due to mating calculated here and the change due to natural selection, calculated in PHASE 1, but not including the order O term Δ(Subscript[PR, M]):

\(\(ΔP2\_M = ΔPR2\_M + \((O\^2\ D1\_{AM, MM, AF}\ \((S\_aa[P\_A] - 2\ S\_Aa[P\_A] + S\_AA[P\_A])\) + 
              O\^2\ D1\_{AM, MF}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\) + 
              O\^2\ D1\_{AM, MM}\ \((\(-S\_aa[P\_A]\) + P\_A\ S\_aa[P\_A] + 
                    S\_Aa[P\_A] - 2\ P\_A\ S\_Aa[P\_A] + 
                    P\_A\ S\_AA[P\_A])\))\);\)\)

\(eqn\_{AM, MM} = 
      Collect[SeriesCoefficient[
          Series[\((\(\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 0, 
                                        0}] /. {P\_AM -> P\_A, 
                                        P\_AF -> P\_A, 
                                        P\_MM -> P\_M, 
                                        P\_MF -> P\_M}\) /. 
                                    P\_M -> P\_M + ΔP\_M\) /. 
                                  P\_A -> P\_A + ΔP\_A\) /. 
                                subnextgen)\) - D\_{AM, MM})\) /. 
                        ChangeVars\) /. SimpleSubs\) /. SubDSmall\) /. 
                  subTrans\) /. subρ)\), {O, 0, 1}], 1], {D1\_{AM, AF}, 
          D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
          D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MF} = 
      Collect[SeriesCoefficient[
          Series[\((\(\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 0, 0, 
                                        1}] /. {P\_AM -> P\_A, 
                                        P\_AF -> P\_A, 
                                        P\_MM -> P\_M, 
                                        P\_MF -> P\_M}\) /. 
                                    P\_M -> P\_M + ΔP\_M\) /. 
                                  P\_A -> P\_A + ΔP\_A\) /. 
                                subnextgen)\) - D\_{AM, MF})\) /. 
                        ChangeVars\) /. SimpleSubs\) /. SubDSmall\) /. 
                  subTrans\) /. subρ)\), {O, 0, 1}], 1], {D1\_{AM, AF}, 
          D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
          D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

\(eqn\_{AM, MM, AF} = 
      Collect[SeriesCoefficient[
          Series[\(\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                        0}] /. {P\_AM -> P\_A, 
                                      P\_AF -> P\_A, P\_MM -> P\_M, 
                                      P\_MF -> P\_M}\) /. 
                                  P\_M -> P\_M + ΔP\_M\) /. 
                                P\_A -> P\_A + ΔP\_A\) /. 
                              subnextgen)\) - D\_{AM, MM, AF})\) /. 
                      ChangeVars\) /. SimpleSubs\) /. SubDSmall\) /. 
                subTrans\) /. subρ, {O, 0, 1}], 1], {D1\_{AM, AF}, 
          D1\_{MM, MF}, D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, 
          D1\_{AM, MM, MF}, D1\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
              eqn\_{AM, MM, AF} == 0}, {D1\_{AM, MM}, D1\_{AM, MF}, 
              D1\_{AM, MM, AF}}] // Simplify\) // Flatten\)

finalΔ(Subscript[P, M]) = 
      Factor[Δ(Subscript[P, M]) /. subQLE]

Again, let's derive \(eqn\_{AM, MM, AF}\) without making the subρ substitution (to see if it helps interpret the results):

\(eqn\_{AM, MM, AF} = 
      Collect[SeriesCoefficient[
          Series[\(\(\(\((\((\(\(\(DfromX[{AM, MM, AF, MF}, {1, 1, 1, 
                                      0}] /. {P\_AM -> P\_A, 
                                    P\_AF -> P\_A, P\_MM -> P\_M, 
                                    P\_MF -> P\_M}\) /. 
                                P\_M -> P\_M + ΔP\_M\) /. 
                              P\_A -> P\_A + ΔP\_A\) /. 
                            subnextgen)\) - D\_{AM, MM, AF})\) /. 
                    ChangeVars\) /. SimpleSubs\) /. SubDSmall\) /. 
              subTrans, {O, 0, 1}], 1], {D1\_{AM, AF}, D1\_{MM, MF}, 
          D1\_{AM, MM}, D1\_{AM, MF}, D1\_{AM, MM, AF}, D1\_{AM, MM, MF}, 
          D1\_{AM, MM, AF, MF}}, Factor]\)

\(subQLE2 = \(Solve[{eqn\_{AM, MM} == 0, eqn\_{AM, MF} == 0, 
              eqn\_{AM, MM, AF} == 0}, {D1\_{AM, MM}, D1\_{AM, MF}, 
              D1\_{AM, MM, AF}}] // Simplify\) // Flatten\)

finalNOSUBΔ(Subscript[P, M]) = 
      Factor[Δ(Subscript[P, M]) /. subQLE2]

In the text, we focus only on a graphical interpretation of the above (next section)

Case where K = aveκ/aveρ is constant

We know that the following is zero (QLE condition from the leading order terms).

\(equileqn = 
      Factor[\((\(\(\(\(-aveδ\) + aveρ - 32\ D0\_{AM, AF} + 
                    16\ aveκ\ D0\_{AM, AF} + 
                    16\ aveρ\ D0\_{AM, AF} + 
                    16\ aveδ\ D0\_\({AM, AF}\)\%2 - 
                    64\ aveκ\ D0\_\({AM, AF}\)\%2 + 
                    48\ aveρ\ D0\_\({AM, AF}\)\%2 /. 
                  aveδ -> 0\) /. Δδ -> 
                  0\) /. Δκ -> 
                K*Δρ\) /. 
            aveκ -> K*aveρ)\)]\)

\(Solve[equileqn == 0, D0\_{AM, AF}] // Simplify\)

The relevant root increases with aveρ:

Plot3D[((-4 + 2 aveρ (1 + K) + (Sqrt[16 - 16 aveρ (1 + K) + ave(ρ^2) (1 + 12 K + 4 (K^2))]))/(4 aveρ (-3 + 4 K))), {aveρ, 0.001, 0.99}, {K, 0, 1}]

Plot3D[-((4 - 
              2 aveρ (1 + 
                    K) + (Sqrt[16 - 16 aveρ (1 + K) + ave(ρ^2) (1 + 12 K + 4 (K^2))]))/(4 aveρ (-3 + 
                  4 K))), {aveρ, 0.0001, 1}, {K, 0, 
        1}]

The rate of assortative mating will not evolve if the following is zero:

workwithme = 
      Factor[finalNOSUBΔ(Subscript[P, M])/(O Δρ (1 - (Subscript[P, M])) (Subscript[P, M])) /. 
                aveδ -> 0 /. Δδ -> 
                0 /. Δκ -> 
              K*Δρ /. 
          aveκ -> K*aveρ]

This will equal zero when \(D0\_{AM, AF} = 1\/\(\(-4\) + 16\ K\)\)

\(Solve[% == 0, D0\_{AM, AF}]\)

which in turn requires that aveρ = ((-1 + 4 K)/(4 (K^2)))

\(equileqn /. D0\_{AM, AF} -> 1\/\(\(-4\) + 16\ K\) // 
      Factor\)

Solve[% == 0, aveρ]

This solution for the disequilibrium is biologically valid only when \(D0\_{AM, AF}\)lies in the range of {-1/4,1/4}, which requires that K≥1/2:

Plot[
      (1/(-4 + 16 K)), {K, 0, 
        1}, 
PlotRange -> {{0, 1}, {-1/4, 
            1/4}}]

\(Factor[\(\(\(\(\(finalNOSUBΔP\_M/\((O\ Δρ\ \((1 - P\_M)\)\ P\_M)\) /. 
                  aveδ -> 0\) /. Δδ -> 
                  0\) /. Δκ -> 
                K*Δρ\) /. 
            aveκ -> K*aveρ\) /. 
          aveρ -> \(\(-1\) + 4\ K\)\/\(4\ K\^2\)\) /. 
        D0\_{AM, AF} -> 1\/\(\(-4\) + 16\ K\)]\)

The above defines the thick curve in Figure 4, along which there is no change in the modifier frequency.  In addition, we know from the work with weak assortment that a second such curve exists at 4  (Subscript[H, ns]).

DisplayTogether[
Plot[((-1 + 4 K)/(4 (K^2))), {K, 0.5, 1}, Frame -> True, PlotRange -> {{0, 1}, {0, 1}}, 
        AspectRatio -> 1], 
Plot[
        4  (Subscript[H, ns]) /. (Subscript[H, ns]) -> 0.02, {K, 0, 1}, Frame -> True, 
        PlotRange -> {{0, 1}, {0, 1}}, 
        AspectRatio -> 1]
]

Export["Fig.eps", %];

The following confirms that the upper curve is repelling and the lower one attracting:

\(sign[K_, aveρ_] = 
      FullSimplify[
        workwithme /. 
          D0\_{AM, AF} -> \(\(-4\) + 2\ aveρ\ \((1 + K)\) + \@\(16 - 16\ aveρ\ \((1 + K)\) + aveρ\^2\ \((1 + 12\ K + 4\ K\^2)\)\)\)\/\(4\ aveρ\ \((\(-3\) + 4\ K)\)\), {aveρ ≥ 0, 
          aveρ < 1, K ≥ 0, K ≤ 1}]\)

The change in the modifier is negative while aveρ is small enough (below the thick curve in Figure 4), but positive above it.

Plot3D[
      sign[K, aveρ], {aveρ, 0.0001, 1}, {K, 0, 0.99}]

Matessi's case

We know that the following is zero (QLE condition from the leading order terms).

\(equileqnM = 
      Factor[\((\(\(\(\(-aveδ\) + aveρ - 32\ D0\_{AM, AF} + 
                    16\ aveκ\ D0\_{AM, AF} + 
                    16\ aveρ\ D0\_{AM, AF} + 
                    16\ aveδ\ D0\_\({AM, AF}\)\%2 - 
                    64\ aveκ\ D0\_\({AM, AF}\)\%2 + 
                    48\ aveρ\ D0\_\({AM, AF}\)\%2 /. 
                  aveδ -> 0\) /. Δδ -> 
                  0\) /. aveκ -> v\) /. 
            aveρ -> \((1 - \((1 - v)\)^4)\))\)]\)

\(Solve[% == 0, D0\_{AM, AF}] // Simplify\)

The relevant root increases with v:

DisplayTogether[
      Plot[(4 - 10 v + 12 (v^2) - 8 (v^3) + 
              2 (v^4) + (Sqrt[16 - 80 v + 164 (v^2) - 184 (v^3) + 132 (v^4) - 68 (v^5) + 28 (v^6) - 8 (v^7) + (v^8)]))/(32 v - 72 (v^2) + 48 (v^3) - 
              12 (v^4)), {v, 0, 1}], 
      Plot[(-4 + 10 v - 12 (v^2) + 8 (v^3) - 
              2 (v^4) + (Sqrt[16 - 80 v + 164 (v^2) - 184 (v^3) + 132 (v^4) - 68 (v^5) + 28 (v^6) - 8 (v^7) + (v^8)]))/(4 v (-8 + 18 v - 
                  12 (v^2) + 3 (v^3))), {v, 0, 1}, 
        PlotStyle -> Dashing[{0.01}]], 
      PlotRange -> {{0, 1}, {0, 1}}
]

We assume that the modifier is weak so that Δv is small (v need not be):

Factor[
      Normal[Series[(1 - (1 - (v + Δv))^4) - (1 - (1 - v)^4), {Δv, 0, 1}]]]

Factor[finalNOSUBΔ(Subscript[P, M])/(O Δv (1 - (Subscript[P, M])) (Subscript[P, M])) /. 
                  aveδ -> 0 /. Δδ -> 
                  0 /. Δκ -> Δv /. Δρ -> 4 (((1 - v))^3) Δv /. 
          aveκ -> v /. 
        aveρ -> (1 - (1 - v)^4)]

\(changeMatessi = 
      FullSimplify[% /. 
          D0\_{AM, AF} -> \((\(-4\) + 10\ v - 12\ v\^2 + 8\ v\^3 - 
                  2\ v\^4 + \@\(16 - 80\ v + 164\ v\^2 - 184\ v\^3 + 132\ v\^4 - 68\ v\^5 + 28\ v\^6 - 8\ v\^7 + v\^8\))\)/\((4\ v\ \((\(-8\) + 18\ v - 
                      12\ v\^2 + 3\ v\^3)\))\), {v > 0, v < 1}]\)

This is negative while v is small enough, but now we see the case discussed by Matessi (where there is a second cut-off favoring complete assortment):

Plot[changeMatessi, {v, 0, 1}, 
      PlotRange -> {{0, 1}, {-0.1, 0.1}}]

DisplayTogether[
ListPlot[
        Table[{aveκ/aveρ, aveρ} /. 
              aveκ -> v /. 
            aveρ -> (1 - (1 - v)^4), {v, 0.001, 1, 0.01}], 
        PlotJoined -> True, PlotRange -> {{0, 1}, {0, 1}}, 
        AspectRatio -> 1, Frame -> True, 
        PlotStyle -> Dashing[{0.01, 0.04}]], 
      Plot[((-1 + 4 K)/(4 (K^2))), {K, 0.5, 1}, Frame -> True, 
        PlotRange -> {{0, 1}, {0, 1}}, 
        AspectRatio -> 1], 
Plot[
        4  (Subscript[H, ns]) /. (Subscript[H, ns]) -> 0.02, {K, 0, 1}, Frame -> True, 
        PlotRange -> {{0, 1}, {0, 1}}, 
        AspectRatio -> 1]
]

aveκ/aveρ /. aveκ -> v /. 
      aveρ -> (1 - (1 - v)^4)

Export["Fig2.eps", %];

The cross-over occurs once v rises above ~0.586.

Solve[changeMatessi == 0, v]

% // N

Matessi et al report S = -ln(1-v) to be 0.855 when selection was the weakest considered (in Table 3), which is near that predicted by the QLE (which assumes weak selection):

-Log[1 - (2 - (Sqrt[2]))] // N

Also the ESS is fairly accurately predicted.  The QLE predicts:

Transpose[-Log[
                1 - 2  α] /. α -> β {0.1, 0.3, 
                  0.5, 0.7, 0.9} /. β -> {0.1, 0.3, 0.5, 1, 2, 
              4}];
MatrixForm[%]

compared to the numerical analysis of Matessi:

{{0.02, 0.06, 0.105, 0.155, 0.220}, {0.055, 0.190, NA, NA, 
          NA}, {0.09, NA, NA, NA, NA}, {0.15, NA, NA, NA, NA}, {0.25, NA, NA, 
          NA, NA}, {0.41, NA, NA, NA, NA}};
MatrixForm[%]

The repelling boundary occurs where (Subscript[H, animal]) becomes zero as \(D0\_{AM, AF}\) rises

We can predict when there should be a switch by considering when (Subscript[H, animal]) (which is called (Subscript[H, tot]) in the text) becomes zero .  Technically, (Subscript[H, tot]) must be calculated across the generation (as in the next section), but here we use the weak assortment approximation in Equation (18) to get the same answer.

\(\(H\_animal = 
        H\_ns - 1/
              2*\((\((P\_A\^2 + D0\_{AM, AF})\) \((\(-2\)\ aveκ + 
                      aveρ)\) + \((2 \( P\_A\) \((1 - P\_A)\) - 
                      2  D0\_{AM, AF})\) \((2  
                      aveκ)\) + \((\((1 - P\_A)\)\^2 + 
                      D0\_{AM, AF})\) \((\(-2\)\ aveκ + 
                      aveρ)\))\);\)\)

To leading order, (Subscript[H, ns]) is zero:

Collect[(Subscript[H, animal]) /. (Subscript[H, ns]) -> 0, aveκ, Factor]

\(\(% /. D0\_{AM, AF} -> 0\) /. P\_A -> 1/2 // 
      Factor\)

When \(D0\_{AM, AF}\)is nearly absent (starting near random mating), (Subscript[H, animal]) is negative (~-(1/4) aveρ).

The build-up of disequilibrium will make (Subscript[H, animal]) more positive if K=ave(κ/ave)ρ > (1/4):

\(D[H\_animal, D0\_{AM, AF}] // Factor\)

In this case, if there happens to be a lot of disequilibrium to begin with (high assortment initially), then (Subscript[H, animal]) can flip sign and become positive.

We can find the value of \(D0\_{AM, AF}\) at which (Subscript[H, animal])is zero from:

\(\(Solve[\((\(H\_animal /. H\_ns -> 0\) /. 
                P\_A -> 1/2)\) == 0, D0\_{AM, AF}] // Simplify\) // 
      Flatten\)

Assuming that K = aveκ/aveρ , we find that (Subscript[H, animal]) = 0 at exactly the same equilbrium solution (\(D0\_{AM, AF} -> 1\/\(4\ \((\(-1\) + 4\ K)\)\)\) and aveρ -> ((-1 + 4 K)/(4 (K^2)))) as found when we determined where Δ(Subscript[P, M]) = 0:

\(\(Solve[\((\(\(H\_animal /. H\_ns -> 0\) /. P\_A -> 1/2\) /. 
                aveκ -> K*aveρ)\) == 0, D0\_{AM, AF}] // 
        Simplify\) // Flatten\)

\(Factor[\ \(\(equileqn /. \ 
            D0\_{AM, AF} -> 1\/\(4\ \((\(-1\) + 4\ K)\)\)\) /. 
          aveδ -> 0\) /. 
        aveκ -> K*aveρ]\)

Solve[% == 0, aveρ] // Simplify // Flatten

Derivation of (Subscript[H, animal]) (full)

Kill the kernel and then enter the following to calculate the full fitness difference between heterozygotes and homozygotes across the life cycle.

Selection first

\(\(W\_{0, 0, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 0} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 0, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 0, 1} = 1 + O*S\_aa[P\_A];\)\)
\(\(W\_{1, 0, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 0, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{0, 1, 1, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 0} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{0, 1, 1, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 0, 1} = 1 + O*S\_Aa[P\_A];\)\)
\(\(W\_{1, 1, 1, 0} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 0, 1, 1} = 1 + O*S\_AA[P\_A];\)\)
\(\(W\_{1, 1, 1, 1} = 1 + O*S\_AA[P\_A];\)\)

\(\(W\&_ = 
        Factor[\(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0} + \(X\_{0, 0, 0, 1}\) 
                W\_{0, 0, 0, 1} + \(X\_{0, 0, 1, 0}\) 
                W\_{0, 0, 1, 0} + \(X\_{0, 1, 0, 0}\) 
                W\_{0, 1, 0, 0} + \(X\_{1, 0, 0, 0}\) 
                W\_{1, 0, 0, 0} + \(X\_{0, 0, 1, 1}\) 
                W\_{0, 0, 1, 1} + \(X\_{0, 1, 0, 1}\) 
                W\_{0, 1, 0, 1} + \(X\_{1, 0, 0, 1}\) 
                W\_{1, 0, 0, 1} + \(X\_{0, 1, 1, 0}\) 
                W\_{0, 1, 1, 0} + \(X\_{1, 1, 0, 0}\) 
                W\_{1, 1, 0, 0} + \(X\_{1, 0, 1, 0}\) 
                W\_{1, 0, 1, 0} + \(X\_{0, 1, 1, 1}\) 
                W\_{0, 1, 1, 1} + \(X\_{1, 1, 1, 0}\) 
                W\_{1, 1, 1, 0} + \(X\_{1, 0, 1, 1}\) 
                W\_{1, 0, 1, 1} + \(X\_{1, 1, 0, 1}\) 
                W\_{1, 1, 0, 1} + \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1} /. 
            SimpleSubs];\)\)

\(\(X\_{0, 0, 0, 0}' = \(X\_{0, 0, 0, 0}\) W\_{0, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 0, 1}' = \(X\_{0, 0, 0, 1}\) W\_{0, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 0}' = \(X\_{0, 0, 1, 0}\) W\_{0, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 0}' = \(X\_{0, 1, 0, 0}\) W\_{0, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 0}' = \(X\_{1, 0, 0, 0}\) W\_{1, 0, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 0, 1, 1}' = \(X\_{0, 0, 1, 1}\) W\_{0, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 0, 1}' = \(X\_{0, 1, 0, 1}\) W\_{0, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 0, 1}' = \(X\_{1, 0, 0, 1}\) W\_{1, 0, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 0}' = \(X\_{0, 1, 1, 0}\) W\_{0, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 0}' = \(X\_{1, 1, 0, 0}\) W\_{1, 1, 0, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 0}' = \(X\_{1, 0, 1, 0}\) W\_{1, 0, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{0, 1, 1, 1}' = \(X\_{0, 1, 1, 1}\) W\_{0, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 0}' = \(X\_{1, 1, 1, 0}\) W\_{1, 1, 1, 0}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 0, 1, 1}' = \(X\_{1, 0, 1, 1}\) W\_{1, 0, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 0, 1}' = \(X\_{1, 1, 0, 1}\) W\_{1, 1, 0, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)
\(\(X\_{1, 1, 1, 1}' = \(X\_{1, 1, 1, 1}\) W\_{1, 1, 1, 1}/W\&_ /. 
            SimpleSubs // Factor;\)\)

Assortative mating

Read the matrix below as female genotypes in rows, male genotypes in columns, assuming female choice...
We assume that females have dislikes:
	* for any different genotype  (ρ).

Such dislikes cause a reduction in female fitness (a direct cost of mate choice).

MatrixForm[
      MateMat = {{1 - δ, 1 - κ, 1 - ρ}, {1 - κ, 
            1 - δ, 1 - κ}, {1 - ρ, 1 - κ, 
            1 - δ}}]

This is a female choice model...In the sense, that only the females modifier status matters...

ModMat = {{δ -> (Subscript[δ, mm]), κ -> (Subscript[κ, mm]), ρ -> (Subscript[ρ, mm])}, {δ -> (Subscript[δ, Mm]), ρ -> (Subscript[ρ, Mm]), κ -> (Subscript[κ, Mm])}, {δ -> (Subscript[δ, MM]), κ -> (Subscript[κ, MM]), ρ -> (Subscript[ρ, MM])}};

Genotype frequencies at the A locus are calculated in the order aa=1, Aa=2, AA=3.

In the function below, female genome is given by {m,n,o,p} and male genome by {q,r,s,t} where letters take values 0 or 1 dpending on allelic status at that position in the genome.

WMate[m_, n_, o_, p_, q_, r_, s_, t_] := 
        MateMat[[m + o + 1, q + s + 1]] /. 
          ModMat[[n + p + 1]];

\(For[m = 1, 
      m ≤ 2, \(m++\), 
For[n = 1, 
        n ≤ 2, \(n++\), 
For[o = 1, 
          o ≤ 2, \(o++\), 
For[p = 1, 
            p ≤ 2, \(p++\), 
            NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 0]]]]\)

\(\(\(
\)\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      NormalFemale\_{m - 1, n - 1, o - 1, p - 1} = 
                        NormalFemale\_{m - 1, n - 1, o - 1, p - 1} + 
                          X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]]]]]]]]];\)\(
\)
    \)\)\)

\(\(\(
\)\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, 
                          t - 1] = 
                        WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                            s - 1, t - 1]/
                          NormalFemale\_{m - 1, n - 1, o - 1, p - 1}]]]]]]]];\)\)\)

\(\(M\&_ = 0;\)\)
\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      M\&_ = M\&_ + 
                          X\_{m - 1, n - 1, o - 1, p - 1}'*
                            X\_{q - 1, r - 1, s - 1, t - 1}'*
                            WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, 
                              t - 1]]]]]]]]];\)\)
\(\(M\&_ = Factor[M\&_];\)\)

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 2, \(t++\), 
                      Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\) = X\_{m - 1, n - 1, o - 1, p - 1}'*X\_{q - 1, r - 1, s - 1, t - 1}'*
                          WMate[m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, 
                              s - 1, t - 1]/M\&_]]]]]]]];\)\)

Evaluates the fitness of each genotype (including natural and sexual selection but not recombination).

For[i = 1, i ≤ 2, i++, 
      For[j = 1, j ≤ 2, j++, 
        For[k = 1, k ≤ 2, k++, 
          For[l = 1, l ≤ 2, l++, 
            (Subscript[X, {i - 1, j - 1, k - 1, l - 1}

                  ])'' = 0]]]]

\(\(For[m = 1, 
        m ≤ 2, \(m++\), 
For[n = 1, 
          n ≤ 2, \(n++\), 
For[o = 1, 
            o ≤ 2, \(o++\), 
For[p = 1, 
              p ≤ 2, \(p++\), 
For[q = 1, 
                q ≤ 2, \(q++\), 
For[r = 1, 
                  r ≤ 2, \(r++\), 
For[s = 1, 
                    s ≤ 2, \(s++\), 
For[t = 1, 
                      t ≤ 
                        2, \(t++\), 
X\_{m - 1, n - 1, o - 1, p - 1}'' = X\_{m - 1, n - 1, o - 1, p - 1}'' + 
                          Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)/2; 
X\_{q - 1, r - 1, s - 1, t - 1}'' = 
                        X\_{q - 1, r - 1, s - 1, t - 1}'' + 
                          Y\_\(m - 1, n - 1, o - 1, p - 1, q - 1, r - 1, s - 1, t - 1\)/2
]]]]]]]];\)\)

Randomize chromosomes from mother/father

\(T\_{0, 1, 0, 0}\)=((\(X\_{0, 1, 0, 0}\))''+(\(X\_{0, 0, 0, 1}\))'')/2;
\(T\_{1, 0, 0, 0}\)=((\(X\_{1, 0, 0, 0}\))''+(\(X\_{0, 0, 1, 0}\))'')/2;
\(T\_{1, 1, 0, 0}\)=((\(X\_{1, 1, 0, 0}\))''+(\(X\_{0, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 1, 0}\)=((\(X\_{1, 1, 1, 0}\))''+(\(X\_{1, 0, 1, 1}\))'')/2;
\(T\_{1, 1, 0, 1}\)=((\(X\_{1, 1, 0, 1}\))''+(\(X\_{0, 1, 1, 1}\))'')/2;
\(T\_{1, 0, 0, 1}\)=((\(X\_{1, 0, 0, 1}\))''+(\(X\_{0, 1, 1, 0}\))'')/2;

\(X\_{0, 1, 0, 0}'' = 
        T\_{0, 1, 0, 0};\)
\(X\_{0, 0, 0, 1}'' = T\_{0, 1, 0, 0};\)

\(X\_{1, 0, 0, 0}'' = 
        T\_{1, 0, 0, 0};\)
\(X\_{0, 0, 1, 0}'' = T\_{1, 0, 0, 0};\)

\(X\_{1, 1, 0, 0}'' = 
        T\_{1, 1, 0, 0};\)
\(X\_{0, 0, 1, 1}'' = T\_{1, 1, 0, 0};\)

\(X\_{1, 1, 1, 0}'' = 
        T\_{1, 1, 1, 0};\)
\(X\_{1, 0, 1, 1}'' = T\_{1, 1, 1, 0};\)

\(X\_{1, 1, 0, 1}'' = 
        T\_{1, 1, 0, 1};\)
\(X\_{0, 1, 1, 1}'' = T\_{1, 1, 0, 1};\)

\(X\_{1, 0, 0, 1}'' = 
        T\_{1, 0, 0, 1};\)
\(X\_{0, 1, 1, 0}'' = 
        T\_{1, 0, 0, 1};\)

Assuming a weak modifier [Enter]

We assume that the modifier is weak, and we rewrite the assortment rules in terms of the average level of assortment initially, the change in assortment, and the dominance at the modifier locus:

subTrans = 
      Solve[{( (Subscript[ρ, Mm]) - (Subscript[ρ, mm])) == 
              hρ*( (Subscript[ρ, MM]) - (Subscript[ρ, mm])), 
            O*Δρ == ((Subscript[P, M]) ( (Subscript[ρ, MM]) - (Subscript[ρ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[ρ, Mm]) - (Subscript[ρ, mm]))), 
aveρ == ((Subscript[P, M]^2) (Subscript[ρ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[ρ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[ρ, mm])), ( (Subscript[δ, Mm]) - (Subscript[δ, mm])) == hδ*( (Subscript[δ, MM]) - (Subscript[δ, mm])), 
            O*Δδ == ((Subscript[P, M]) ( (Subscript[δ, MM]) - (Subscript[δ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[δ, Mm]) - (Subscript[δ, mm]))), 
aveδ == ((Subscript[P, M]^2) (Subscript[δ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[δ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[δ, mm])), ( (Subscript[κ, Mm]) - (Subscript[κ, mm])) == hκ*( (Subscript[κ, MM]) - (Subscript[κ, mm])), 
            O*Δκ == ((Subscript[P, M]) ( (Subscript[κ, MM]) - (Subscript[κ, Mm])) + (1 - 
                        (Subscript[P, M])) ( (Subscript[κ, Mm]) - (Subscript[κ, mm]))), 
aveκ == ((Subscript[P, M]^2) (Subscript[κ, MM]) + 
                  2  (Subscript[P, M]) (1 - 
                        (Subscript[P, M])) (Subscript[κ, Mm]) + (((1 - 
                            (Subscript[P, M])))^2) (Subscript[κ, mm]))}, {(Subscript[ρ, mm]), (Subscript[ρ, Mm]), (Subscript[ρ, MM]), (Subscript[δ, mm]), (Subscript[δ, Mm]), (Subscript[δ, MM]), (Subscript[κ, mm]), (Subscript[κ, Mm]), (Subscript[κ, MM])}] // Flatten

subnextgen={\(X\_{0, 0, 0, 0}\)->(\(X\_{0, 0, 0, 0}\))'',\(X\_{1, 0, 0, 0}\)->(\(X\_{1, 0, 0, 0}\))'',\(X\_{0, 1, 0, 0}\)->(\(X\_{0, 1, 0, 0}\))'',\(X\_{1, 1, 0, 0}\)->(\(X\_{1, 1, 0, 0}\))'',\(X\_{0, 0, 1, 0}\)->(\(X\_{0, 0, 1, 0}\))'',\(X\_{1, 0, 1, 0}\)->(\(X\_{1, 0, 1, 0}\))'',\(X\_{0, 1, 1, 0}\)->(\(X\_{0, 1, 1, 0}\))'',\(X\_{1, 1, 1, 0}\)->(\(X\_{1, 1, 1, 0}\))'',\(X\_{0, 0, 0, 1}\)->(\(X\_{0, 0, 0, 1}\))'',\(X\_{1, 0, 0, 1}\)->(\(X\_{1, 0, 0, 1}\))'',\(X\_{0, 1, 0, 1}\)->(\(X\_{0, 1, 0, 1}\))'',\(X\_{1, 1, 0, 1}\)->(\(X\_{1, 1, 0, 1}\))'',\(X\_{0, 0, 1, 1}\)->(\(X\_{0, 0, 1, 1}\))'',\(X\_{1, 0, 1, 1}\)->(\(X\_{1, 0, 1, 1}\))'',\(X\_{0, 1, 1, 1}\)->(\(X\_{0, 1, 1, 1}\))'',\(X\_{1, 1, 1, 1}\)->(\(X\_{1, 1, 1, 1}\))''};

Values of (Subscript[H, animal])

\(\(SubDSmall = {D\_{AM, AF} -> D0\_{AM, AF} + O*D1\_{AM, AF}, 
          D\_{MM, MF} -> O*D1\_{MM, MF}, 
          D\_{AM, MM} -> O*D1\_{AM, MM}, 
          D\_{AM, MF} -> O*D1\_{AM, MF}, 
          D\_{AM, MM, AF} -> O*D1\_{AM, MM, AF}, 
          D\_{AM, MM, MF} -> O*D1\_{AM, MM, MF}, 
          D\_{AM, MM, AF, MF} -> O*D1\_{AM, MM, AF, MF}};\)\)

\(sel\_aa = \(\(\(\(\((X\_{0, 0, 0, 0} + X\_{0, 0, 0, 1} + 
                          X\_{0, 1, 0, 0} + 
                          X\_{0, 1, 0, 1})\)/\((\((1 - P\_A)\)^2 + 
                          D\_{AM, AF})\) - 1 /. subnextgen\) /. ChangeVars\) /. 
              SubDSmall\) /. subTrans\) /. O\  -> 0 // Factor\)

\(sel\_Aa = \(\(\(\(\((X\_{0, 0, 1, 0} + X\_{1, 0, 0, 0} + 
                          X\_{0, 0, 1, 1} + X\_{1, 0, 0, 1} + 
                          X\_{0, 1, 1, 0} + X\_{1, 1, 0, 0} + 
                          X\_{0, 1, 1, 1} + 
                          X\_{1, 1, 0, 1})\)/\((2 \( P\_A\) \((1 - P\_A)\) - 
                          2  D\_{AM, AF})\) - 1 /. subnextgen\) /. 
                ChangeVars\) /. SubDSmall\) /. subTrans\) /. O\  -> 0 // 
        Factor\)

\(sel\_AA = \(\(\(\(\((X\_{1, 0, 1, 0} + X\_{1, 1, 1, 0} + 
                          X\_{1, 0, 1, 1} + X\_{1, 1, 1, 1})\)/\((P\_A^2 + 
                          D\_{AM, AF})\) - 1 /. subnextgen\) /. ChangeVars\) /. 
              SubDSmall\) /. subTrans\) /. O\  -> 0 // Factor\)

(Subscript[H, animalACC]) = Factor[(Subscript[sel, AA]) - 2  (Subscript[sel, Aa]) + (Subscript[sel, aa])]

The following is used to solve for when (Subscript[H, animalACC])=0, recall once again that we know that the following must be zero at QLE when (Subscript[P, A]) = 1/2 (see Calculations to constant order section)

\(equileqn = 
      Factor[\((\(-aveδ\) + aveρ - 32\ D0\_{AM, AF} + 
            16\ aveκ\ D0\_{AM, AF} + 16\ aveρ\ D0\_{AM, AF} + 
            16\ aveδ\ D0\_\({AM, AF}\)\%2 - 
            64\ aveκ\ D0\_\({AM, AF}\)\%2 + 
            48\ aveρ\ D0\_\({AM, AF}\)\%2)\)]\)

subρ = Solve[% == 0, aveρ] // Flatten

Factor[(Subscript[H, animalACC]) /. (Subscript[P, A]) -> 1/2 /. subρ]

\(Solve[% == 0, D0\_{AM, AF}] // Simplify\)

\(Solve[\((equileqn /. 
              D0\_{AM, AF} -> \(\(-1\) + aveκ\)\/\(4\ \((aveδ - aveκ)\)\))\) == 0, aveρ] // Simplify\)

If we constrain K=ave(κ/ave)ρ and set aveδ->0, then we regain the same solution found above (\(D0\_{AM, AF} -> \(1 - K\)\/\(4\ K\)\), aveρ -> ((-1 + 4 K)/(4 (K^2)))), using the weak assortment approximation for (Subscript[H, ns]).

\(Solve[\((\(\(equileqn /. 
                  D0\_{AM, AF} -> \(\(-1\) + aveκ\)\/\(4\ \((aveδ - aveκ)\)\)\) /. aveκ -> K\ aveρ\) /. 
              aveδ -> 0)\) == 0, aveρ] // 
      Simplify\)

\(\(\(\(D0\_{AM, AF} /. 
              D0\_{AM, AF} -> \(\(-1\) + aveκ\)\/\(4\ \((aveδ - aveκ)\)\)\) /. aveκ -> K\ aveρ\) /. 
          aveδ -> 0\) /. 
        aveρ -> \(\(-1\) + 4\ K\)\/\(4\ K\^2\) // Factor\)