MacDonald MWB and SWB with mating

D. Gurarie ©

Supplement notebook for 
“Population biology of Schistosoma mating, aggregation, and transmission breakpoints : More reliable model analysis for the end - game in communities at risk”
by David Gurarie and Charles H.King

Codes

General codes: convert algebraic system to DS et al

(*Rules: head->function*)
InR:=InterpolatingFunction[x__]:>InterpolatingFunction[x][t];
(*Convert AS -> DS*)
DSV[as_,v_,iv_,t0_]:=
Block[{ru,va},
ru[t_]=(x_/;MemberQ[Flatten@v,x]:>x[t]);
va[t_]=v/.ru@t;
{va'[t]==(as/.ru@t),va[t0]==iv}];

Plotting codes

(*Plot time series*)
PTS[f_,{t1_,t2_},ra_,st_,la_,op___]:=Plot[Evaluate@f,{t,t1,t2},PlotRange->ra,PlotStyle->st,Frame->True,FrameLabel->la,BaseStyle->{12,Italic},op];
Bst=BaseStyle->{12,Italic};
FrT[r_]:=FrameTicks->{{N@FindDivisions[r,4],{}},{Automatic,{}}};
(*Graphics Row*)
GRo[g_,op___]:=GraphicsRow[g,ImageSize->Large,Spacings->-10,op]
(*Legend Label*)LaB[n_,v_]:=n<>" = "<>ToString@v
SetAttributes[LaB,Listable]

Macdonald MWB with mating

(*Macdonald with human/snail FOI =(Lh,Ls); mortalities =(mw,ms), snail pop s*)
MacF[(*H-S FI*){Lh_,Ls_},{(*worm mort*)mw_,(*snail mort*)ms_},(*snail pop*)s_]:={Lh-mw w,Ls (w/2)(s-y)-ms y};
(*Monogamous NB mating function*)
ϕNB[m_,k_]=1-Hypergeometric2F1[(1/2),1+k,2,((-2m)/k)];
(*NB zero Prevalence*)
pNB[w_,k_]=1-((((k/(w+k))))^k)(1+((k w)/(k+w)));
(*NB Mated Macd*)
MdN[{a_,b_,k_,mw_,ms_},s_]=MacF[{a y,b ϕNB[w,k]},{mw,ms},s];
(*y-Equilibria F(y) for mated Macdonald *)
Eqy[{a_,b_,k_,mw_,ms_},s_]=(((a b)/(2 mw ms)) ϕNB[(a/mw) y,k](s-y)-1)y;

SWB with mating

(*Host system*)
HTM[{λ_,μ_,γ_},n_,h_]:=
Table[λ h[k-1]-(λ Sign[n-k]+k γ+μ)h[k]+(k+1)γ h[k+1],{k,0,n}]/.{h[-1]->0,h[n+1]->0};
(*Monogamous mated couples count*)
MC[n_]=(n/2)(1-(2^(-2Floor[n/2]))Binomial[2Floor[n/2],Floor[n/2]]);
(*Mated Couple count withAllee*)
MCa[n_,q_]=MC[n](1-(q^n));
(*SWB with mating + Allee q*)
SWA[(*strata*){n_,dw_,q_},(*Demographics/biology*){μ_,γ_,ν_},(*Absolute Transmision rates: a=a*γ;b=b*ν*){a_,b_},(*name*)h_,(*Source*)so_]:=
{(HTM[{((a y)/dw),μ,γ},n,h]+so),b Sum[ MC[dw k](1-(q^(dw k)))h[k],{k,n}](1-y)- ν y};
(* SWB children equilibria *)
SWc[l_,m_,nn_]:=
Module[{BaM,h},
(*Band matrix*)
BaM[(*FI*)L_,(*Host turnover*)M_,(*Parasite mort*)γ_,(*strata*)n_]:=SparseArray[{Band[{1,1}]->-(L(1-UnitVector[n,n])+M+γ Range[0,n-1]),Band[{2,1}]->L,Band[{1,2}]->γ Range[n-1]},{n,n}];(*H equilibrium distribution with source so*)h=(Inverse@BaM[l,m,1,nn+1]). UnitVector[nn+1,1];
(h/(Total@h))];
SetAttributes[SWc,Listable]
(*Auxiliary f-n for SWB-prevalence*)
BPS[n_,p_]=Clip[-1+(2^(1-n)) Binomial[n,p] Hypergeometric2F1[1,-n+p,1+p,-1],{0,1}];
(*Infected prevalence P(MC>1/p=1-(q^n))*)
pSW[{l_,m_,q_},n_,dw_]:=(Rest@SWc[l/dw,m,n]).BPS[dw Range@n,1/(1-(q^(dw Range@n)))]

NB/Poisson vs SWB distributions

(*NB(k,w*)NB[k_,m_]=NegativeBinomialDistribution[k,(k/(k+m))];
(*Poisson PDF*)Poi[m_,n_]=(((E^(-m)) (m^n))/(n!));
(*Plot SWB, data-range: normalized SWB*)
dSW[l_,m_,n_]:=Thread@{Range[0,n],SWc[l,m,n]};
(*Poisson*)
NB["∞",m_]=PoissonDistribution[m];

Distribution Plots

(*NB with different k*)
Plot[Evaluate[{Table[PDF[NB[k,10],n],{k,(*k-values*)kk1={.1,1,5,"∞"}}]}],{n,0,25},PlotLegends->Placed[LaB["k",kk1],{Right,Top}],
PlotRange->{0,.25},Frame->True,FrameLabel->{"n","(Subscript[h, n])"},BaseStyle->{12,Italic}]

(*SWB with different μ*)
ListPlot[dSW[10,#,25]&/@(mm2={.2,2,10}),PlotMarkers->Automatic,Joined->True,PlotRange->{0,.25},Frame->True,PlotLegends->Placed[LaB["μ",mm2],{Right,Top}],Bst,FrameLabel->{"n","(Subscript[h, n])"}]

(*Poisson with different mean*)DiscretePlot[Evaluate@Poi[mm1={.3,1,5,10},n],{n,0,20},PlotRange->{0,.8},Frame->True,PlotMarkers->Automatic,Joined->True,Filling->None,PlotLegends->Placed[LaB["m",mm1],{Right,Top}],BaseStyle->{12,Italic},FrameLabel->{"n","(Subscript[h, n])"}]

(*SWB with differnt λ*)
ListPlot[dSW[#,.1,20]&/@{.3,1,5,10},PlotMarkers->Automatic,Joined->True,PlotRange->{0,.8},Frame->True,PlotLegends->Placed[LaB["λ",mm1],{Right,Top}],Bst,FrameLabel->{"n","(Subscript[h, n])"}]

MacDonald MWB

Mating functions for 0<k<∞

Plot[Evaluate@{ϕNB[w,(*k values*)kk1={.1,1,20}]},{w,0,10},PlotRange->{0,1},Frame->True,FrameLabel->{"w","ϕ(w,k)"},BaseStyle->{Italic,12},PlotLegends->Placed[LaB["k",{.1,1,"∞"}],{Right,Center}]]

Equilibria: critical parameters (Subscript[R, 0]),k,a/γ, for function F(y)=(Subscript[R, 0])y[(1-y)ϕ-1/(Subscript[R, 0])]

(*Reduced NB-MacDonald equilibrium f-n for rescaled a=a/(γ+μ), b=b/ν*)
FyNB[y_,{a_,b_,k_}]=(((b a)/2) ϕNB[a y,k](1-y)-1)y;
(*Critical BRN R0(k,a) for MacDonald with a=A/γ*)
R0[k_?NumberQ,a_?NumberQ]:=(R0[k,a]=Module[{fR},fR[k1_,a1_]=(((∂_y)ϕNB[a1 y,k1])/(ϕNB[a1 y,k1]));(1/((1-y)ϕNB[a y,k]))/.FindRoot[fR[k,a]==(1/(1-y)),{y,.5}]]);

(*Manipulate parameters (a,b,k) for function F[y,{a,b,k}]*)
Manipulate[Plot[FyNB[y,{a,b,k}],{y,0,1},PlotRange->{-.2,.3}],
{{b,6},1,10},
{{a,1},.2,4},
{{k,.8},.1,5}]

Parameter planes with critical “zero->bistable” transision curves

(*(k,R0)-Parameter plane *)
Block[{(*Critical R0-values*)
rCC=Table[R0[k,a],{(*max load*)a,aa1={.5,1,4}},{k,.02,2,.02}],
(*k values*)kk1={.5,1,1.5},
(*R0 values*)rr1={5.3,6.54,7.6},
pk1=Thread@{kk1,6.54},pr1},
pr1=Thread@{1,rr1};ListLinePlot[rCC,DataRange->{.02,2},Frame->True,FrameLabel->{"k","(Subscript[R, 0])"},Bst,GridLines->{{{1,Dashed}},{{6.54,Dashed}}},PlotLegends->Placed[LaB["a",aa1],{Left,Top}],AspectRatio->1,Epilog->{PointSize@Medium,Point/@{pk1,pr1}}]]

(*Critical curve b(a) for bistable->zero transition in (a,b)-parameter space*)
Module[{bC},
bC[k_,a_]:=((2R0[k,a])/a);SetAttributes[bC,Listable];
Show[PTS[{bC[kk1={.05,1,10},t]},{0,5},{0,10},{"a","b"},PlotLegends->Placed[LaB["k",kk1],{Right,Top}]],
PTS[(2/t),{0,5},{0,10},Gray,"",Filling->Bottom],Bst,AspectRatio->1]]

SWB for single human-snail system

Prevalence Ω: NB-MacDonald vs SWB

(*MWB*)Plot[Evaluate@pNB[w,kk1={10,1,.2}],{w,0,10},Frame->True,FrameLabel->{"MWB","Prevalence"},PlotRange->{0,1},BaseStyle->{12,Italic},PlotLegends->Placed[LaB["k",kk1],{Left,Top}]]

(*SWB *)
(hid=Table[{l,pSW[{l,m,.6},40,1]},{m,mm1={.1,1,5}},{l,0,10,.2}];
ListLinePlot[hid,Frame->True,FrameLabel->{"λ","Prevalence"},PlotRange->{0,1},Bst,PlotLegends->Placed[LaB["μ",mm1],{Left,Top}]])

SWB equilibria

(*Y-equilibria for SWB for a=a/γ;b=b/ν*)
ySW[y_?NumberQ,{n_?NumberQ,dw_?NumberQ,q_?NumberQ,m_?NumberQ,a_?NumberQ,b_?NumberQ}]:=
(ySW[y,{n,dw,q,m,a,b}]=(b (1-y)MCa[dw Range[n],q].Rest@SWc[a y/dw,m,n]- y));

Function F(y)

(*μ dependence of F(y), for dw=2*)With[{tt=Table[ySW[y,{20,d1=2,q1=.95,m,a1=6,b1=6}],{m,{.05,.1,.15}},{y,0,yt=.8,.02}]},
ListLinePlot[tt,DataRange->{0,yt},PlotRange->{-.02,.25},Frame->True,PlotStyle->{{},{},{}},BaseStyle->12,FrameLabel->{"y","Snail F"}]]

(*Allee q dependence of F(Y)*)With[{tt=Table[ySW[y,{20,d1=2,p,.1,a1=6,b1=5.8}],{p,pp1={.94,.95,.96}},{y,0,yz=1,.02}]},
ListLinePlot[tt,DataRange->{0,yz},
PlotRange->{{0,.8},{-.1,.2}},
Frame->True,Bst,FrameLabel->{"y","Snail F"},
PlotLegends->Placed[LaB["q",pp1],{Left,Top}]]]

Equilibia

(*Parameter choice for breakpooint*)pa2={(*# strata*)10,(*dw*)2,(*q*).95,(*μ*)m1=.2,a1=6,b1=7};
(*SWB equilibria*)
(*Breakpoint SWB-equilibria*)
hQ1=With[{(*breakpoint*)eq1=FindRoot[ySW[y,pa2],{y,.2}]},SWc[((a1 y)/d1)/.eq1,m1,n1=10]];(*Endemic SWB-equilibria*)hQ2=With[{(*endemic*)eq2=FindRoot[ySW[y,pa2],{y,1}]},SWc[((a1 y)/d1)/.eq2,m1,n1]];
ListLinePlot[{hQ1,hQ2},PlotRange->All,DataRange->{0,n1},Frame->True,
PlotMarkers->Automatic,
Bst,FrameLabel->{"w","(SuperStar[h])(w)"},PlotLegends->Placed[{"Breakpoint","Endemic"},{Right,Top}],Bst]

Breakpoint regions for SWB

(*Manipulate b in F(y,...b) for breakpoint analysis*)
Manipulate[
With[{tt=Table[{y,ySW[y,{20,dw,q,m,a,b}]},{y,0,1,.02}]},
ListLinePlot[tt,PlotRange->{{0,yt},{-f0,f0}}]],
{{dw,1},Range[1,10]},
{{m,.1},.05,.5},
{{a,2.5},1,10},
{{b,4},1,20},
{{q,.6},.01,.99},
{{yt,.8},.1,1},
{{f0,.2},.0001,.5},
Bookmarks->{"dw=1":>{a=1.3`,b=20.`,dw=1,f0=0.15`,m=0.1`,q=0.5`,yt=0.8`},"dw=2":>{a=3.5`,b=5.823`,dw=2,f0=0.02`,m=0.1`,q=0.9`,yt=0.5`},
"dw=2a":>{a=6`,b=2.8`,dw=2,f0=0.02`,m=0.1`,q=0.9`,yt=0.5`}}]

Critical (“breakpoint “) value (SuperStar[b])(a) for dw=2

(*Max F[y]*)MaY[n_,dw_,m_,a_,b_,q_]:=Max@Table[ySW[y,{n,dw,q,m,a,b}],{y,.01,1,.025}];
(*Zoom f-n*)
Zom[{x_,y_},f_]:=Which[f[((x+y)/2)]<0,{x,((x+y)/2)},f[((x+y)/2)]>0,{((x+y)/2),y}];
(*Compute critical (SuperStar[b])(a)*)NLB[a_,q_,m_]:=With[{b0=((4(1+m))/((1-(q^2))a))},NestWhile[Zom[#,MaY[20,2,m,a,#,q]&]&,{b0,0},Abs[#[[1]]-#[[2]]]>.001&]];

(*Upper bound of breakpoint region: critical B-values for Max[F]>0, Allee q*)BcV[q_]:=Table[NLB[a,q,.2],{a,1,10,.25}];
(*Upper bound of breakpoint region: critical F'[0]<0 curve of A,q, μ=m*)
BMV[a_,q_,m_]=((4(1+m))/((1-(q^2))a));

(*Plot breakpoint region for AAllee =q*)
PBR[q_]:=Block[{(*a-range*)raG=Range[1,10,.25],
bbz=BMV[raG,q,.2],abc=Mean/@BcV[q]},
ListLinePlot[{abc,bbz},DataRange->{1,10},Frame->True,PlotRange->{0,30},FrameLabel->{"A","B"},Bst,Filling->{1->{2}},PlotLabel->Row[{"q = ",q}],PlotStyle->Gray]]

(*Test*)PBR@.95

MDA control

Macdonald

Codes

(*Extended MWB system for treatment for basic as, with untreated=w tretead=u; treatment fractions = f*)
EAS[as_,w_,u_,f_]:={as[[1]],Sign[f]as[[1]]/.Thread[w->u],as[[2]]/.Thread[w->(f u+w(1-f))]};
(*Event control with regular timing*)
WE1[{ww_,(*Covered*)uu_,ff_},{fc_,ep_,Ft_}]:=With[{w=ww[t],u=uu@t,f=ff@t},
WhenEvent[Mod[t,Ft]==0,
{w->f u+(1-f)w,
u->ep w,f->fc}]];
(*Endemic equilibrium for pretreatment Initialization*)
EqI[{a_,b_,k_,γ_,ν_},s_]:={a/γ,0,1} y/. FindRoot[Eqy[{a,b,k,γ,ν},s],{y,0.95`,0,1}];
(*Combined MWB: for untreated w, treated u*)
mWB=(1-f)w+f u;

Endemic  initialization; DS

(*transmission pars for NB MacDonald*)
paNB={0.8`,16.35`,0.14`,0.35,5.`};
(*Endemic initialization*)wyM={w0,u0,y0}=EqI[paNB,1];
(*NB-MacDonald DS*)
dsNB=DSV[EAS[MdN[paNB,1],w,u,f@t],{w,u,y},wyM,0];

3 - year control with cover f=.7; drug efficacy ϵ=.1

(*Test run*)
{cNw,cNu,cMW,cNy}=NDSolveValue[{dsNB,f[0]==0,
WE1[{w,u,f},{(*Cover*)fc1=.7,(*Efficacy*)eh1=.1,(*Frequency*)3}]},
{w,u,mWB,y},
{t,t3=25},DiscreteVariables->{f}];

(*Plot control solutions*)GRo[{PTS[{cMW,cNw,cNu}/.InR,{0,t3},rr={0,2},{Thick,{},Dashed},{"Year","w(t)"},FrT@rr],
PTS[pNB[cMW,.14]/.InR,{0,t3},rr={0,.25},{Thick},{"Year","P(t)"},FrT@rr],
PTS[cNy/.InR,{0,t3},rr={0,1},{{},Thick,Dashed},{"Year","y(t)"},FrT@rr]}]

(*Plot MWB and NB-prevalence*)GRo[{PTS[{cMW,cNw,cNu}/.InR,{0,t3},rr={0,2},{},{"Year","MWB"},FrT@rr],
PTS[pNB[cMW,.14]/.InR,{0,t3},rr={0,.25},{Black},{"Year","Human Prev"},FrT@rr]}]

SWB

Codes

(*Generate SWB DS with parametric inputs*)DSW[(*strata*){n_,dw_,q_},(*Demog*){μ_,γ_,ν_},(*Trans rates:a*γ;b*ν*){a_,b_},(*name*)h_]:=
Block[{Sh,swb,eq,hQ,in},
(*variables*)hv=(h/@Range[0,n]);
(*Dynamic variables*) hh[t_]=Through@(hv@t);
(*Source*)Sh=μ UnitVector[n+1,1];
(*SWB AS with pars*)
swb=SWA[{n,dw,q},{μ,γ,ν},{a,b},h,Sh];
(*Equilibria y*)eq=FindRoot[ySW[y,{n,dw,q,μ/γ,a/γ,b/ν}],{y,1}];
(*Equilibria h*)hQ=SWc[((a y)/(dw γ))/.eq,μ/γ,n];
(*initialization*)in={hQ,y/.eq};
(*DS-SWB*)DSV[swb,{hv,y},in,0]];

(*Treatment map for h-strata: h[i]-> h[ϵ*i]*)
TrM[h_,n_,e_]:=PadRight[Total/@Map[h,GatherBy[Range[0,n],Floor[2e #]&],{2}],n+1];
(*MDA Event control for SWB with variables hv[t] and control parameters {fc=fraction cover, ep=efficacy, tz= interval(years)}*)
WEB[hv_,{fc_,ep_,tz_}]:=With[{hz=Through@(hv@t),h=Head@hv[[1]],ht=TrM[h,Length@hv-1,ep]/.h[i_]->h[i][t]},
WhenEvent[Mod[t,tz]==0,
{f@t->fc,hz->(1-f@t)hz+f@t ht}]];
(* Event occurence control: remove after m+1 occurence*)
WEBm[hv_,{fc_,ep_,tz_,m_}]:=
With[{hz=Through@(hv@t),h=Head@hv[[1]],ht=TrM[h,Length@hv-1,ep]/.h[i_]->h[i][t]},
WhenEvent[Mod[t,tz]==0,
{f@t->fc,hz->(1-f@t)hz+f@t ht,c[t]->c[t]+1,
If[c[t]>m,"RemoveEvent"]}]];
(*Plots*)
GPa[ch_,cp_,cy_,tp_]:=GRo[{PTS[(ch.rgH)/.InR,{0,tp},All,{{},{},Dashed},{"Years","MWB"}],
PTS[cp/.InR,{0,tp},{0,1},{{},{},Dashed},{"Years","Host Prevalence"}],
PTS[cy/.InR,{0,tp},All,{{},{},Dashed},{"Years","Snail prevalence"}]},ImageSize->Large,Spacings->0];
(*Dynamic SWB prevalence P(MC>1/p=1-(q^n)) - to multiply computed solution cH*)DPS[n_,dw_,q_]:=With[{r=dw Range[n]},BPS[r,1/(1-(q^r))]]

Parameters, DS, initialization

(*pars for Equilibria*){n1=20,d1=2,q1=.9,m1=.1,a1=6,b1=3.27};
(*Strata pars for SWB*)
sPar={n1=20,d1=2,q1=.9};
(*Demographic pars for SWB: human turnover, worm mort, snail mort*)
dPar={μ1,γ1=.25,ν1=5};
(*MWB*)rgH=Range[0,n1];
(*Demographic Source*)
Sh1=(μ1=γ1 m1) UnitVector[n1+1,1];

(*variables*)hv=(h/@Range[0,n1]);
(*Algebraic SWB system*)swb=SWA[sPar,dPar,{a1 γ1,b1 ν1},h,Sh1];
(*Endemic initialization*)inZ={hv,y}/.FindRoot[Flatten@swb,Append[Thread@{hv,1},{y,1}]];
(*Generate DS*)dsb=DSV[swb,{hv,y},inZ,0];

3-year control

(*3- year control*)
{cSh,cSy}=NDSolveValue[{dsb,f[0]==0,WEB[hv,{fc=.75,.1,3}]},
{hv,y},
{t,tf=30},DiscreteVariables->{f}];

(*Generate DS1 with q*)ds1=With[{g1=.25,nu1=5},DSW[{20,2,q2=.85},{.1g1,g1,nu1},{a1 g1, b1 nu1},h]];
{ch1,cy1}=NDSolveValue[{ds1,f[0]==0,WEB[hv,{fc,.1,3}]},
{hv,y},
{t,tf=30},DiscreteVariables->{f}];

(*Solution comparison for different q*)
(*Prevalence *)DpS=DPS[n1,d1,q1];
(*Prevalence 1*)Dp1=DPS[n1,d1,q2];
GPa[{cSh,ch1},{DpS.Rest@cSh,Dp1.Rest@ch1},{cSy,cy1},30]

Control 2: stop after 4 steps. Infection bopunced to endemic level

(*4 year conditional control *){cSh,cSy}=NDSolveValue[{ds1,f[0]==0,c[0]==0,WEBm[hv,{fc=.6,ec=.15,6,ns=3}]},
{hv,y},
{t,tf=60},DiscreteVariables->{f,Element[c,Integers]}];

(*4 year conditional control *){ch1,cy1}=NDSolveValue[{dsb,f[0]==0,c[0]==0,WEBm[hv,{fc,ec,6,ns}]},
{hv,y},
{t,tf=60},DiscreteVariables->{f,Element[c,Integers]}];

(*Prevalence *)DpS=DPS[n1,d1,q1];
(*Prevalence 1*)Dp1=DPS[n1,d1,q2];
GPa[{cSh,ch1},{DpS.Rest@cSh,Dp1.Rest@ch1},{cSy,cy1},tf]