On the Stability of Resource Undermatching in Human Group-Choice

(*author: Isabel Fernández (isa.cf8@gmail.com)*)
(*This notebook simulates the dynamics of the model presented in *)

(*Model parameters*)
ClearAll["Global`*"] (*Clear all*)
G=RandomGraph[{6,10}];
Nod=VertexList[G];(*Set of available options (nodes)*)
A=EdgeList[G];(*Set of undirected edges*)
wi={33,42,53,64,75,87};(*Set of resources associated to each option *)
w=Sum[wi[[i]],{i,1,Length[wi]}];(*Total number of resources*)
Xo={60,40,130,140,150,70};(*Initial distribution of individuals*)
m=Sum[Xo[[i]],{i,1,Length[Xo]}];(*Total number of individuals*)
r=1-(w/m);(*Level of resource shortage*)
Neighbors=Union[Cases[IncidenceList[G,#],x_\[UndirectedEdge]#->x ],Cases[IncidenceList[G,#],#\[UndirectedEdge]x_->x ]]&/@ Nod;(*List of neighbors, how individual can change options*)
xi={Xo};(*xi holds the dynamics of the number of individuals selecting different options*)

(*Dynamics*)
Event[]:=(Pevents=Table[If[(Xo[[#]]-wi[[#]])<(Xo[[Neighbors[[#,i]]]]-wi[[Neighbors[[#,i]]]]),{#,Neighbors[[#,i]]},0],{i,1,Length[Neighbors[[#]]]}]&/@Nod;
Pevents=Flatten[Cases[#,Except[0]]&/@Pevents,1];
(*Set of options for which option i is a better local alternative (Subscript[E, α]). {i,j} indicates that individuals choosing option j may switch to option i*)

Sevents=Subsets[Pevents];(*The set of events is given by the powerset of (Subscript[E, α])*)

Aevents={};
If[Length[DeleteDuplicates[Cases[#,{a_,b_}->a]]]==Length[DeleteDuplicates[Cases[#,{a_,b_}->b]]]==Length[#],AppendTo[Aevents,#]]&/@Sevents[[Range[2,Length[Sevents]]]];(*Because we suppose that not two individuals change the same option  simultaneously and if an active event occurs with (Subscript[e, ij])∈e(k), then (Subscript[e, ij'])∉e(k) for any j'≠j*)

 event=Aevents[[RandomInteger[{1,Length[Aevents]}]]] ;(*Choose a random event from Aevents*)

Xo[[#]]++&/@event[[All,1]];Xo[[#]]--&/@event[[All,2]];(*Updates the number of agents of each node*)

AppendTo[xi,Xo];)
Table[Event[],{i,1,170}];(*Repeat all the process*)

xi1=Ceiling[((r m)/(Length[Nod]))]+Max[wi];xj2=Floor[((r m)/(Length[Nod]))]+Min[wi];
SlideView[Table[Column[{"","                                                      Time k = "<>ToString[k],,Row[{Show[ListLinePlot[Table[{i,xi[[i,j]]-wi[[j]]},{j,1,Length[Nod]},{i,1,k}],LabelStyle->Directive[FontFamily->"Helvetica", FontSize-> 15],PlotStyle->(Directive[AbsoluteThickness[3],#]&/@ColorData[68,"ColorList"]),AspectRatio->1,FrameLabel->{"k","(Subscript[x, i])-(Subscript[w, i])"},PlotRange->{{1,Length[xi]},{-19,79}},Frame->True,Axes->False,ImageSize->430,LabelStyle->{42},Epilog->Inset[Show[ListLinePlot[Table[{i,xi[[i,j]]-wi[[j]]},{j,1,Length[Nod]},{i,1,k}],LabelStyle->Directive[FontFamily->"Helvetica", FontSize-> 15],FrameTicks->{{{xj2-Min[wi],xi1-Max[wi]},None},{{90,160},None}},ImageSize->250,PlotStyle->(Directive[AbsoluteThickness[3],#]&/@ColorData[68,"ColorList"]),PlotRange->{{80,Length[xi]},{xi1-Max[wi]+0.5,xj2-Min[wi]-0.5}},Frame->True,Axes->False],ListLinePlot[{Table[{i,xi1-Max[wi]},{i,Length[xi]}],Table[{i,xj2-Min[wi]},{i,Length[xi]}]},PlotStyle->(Directive[AbsoluteThickness[3],Magenta])]],{120,0}]],ListLinePlot[{Table[{i,xi1-Max[wi]},{i,Length[xi]}],Table[{i,xj2-Min[wi]},{i,Length[xi]}]},PlotMarkers->{""},PlotStyle->(Directive[AbsoluteThickness[3],Magenta])]],,,,
ListLinePlot[Table[{i,wi[[j]]/xi[[i,j]]},{j,1,Length[Nod]},{i,1,k}],PlotStyle->(Directive[AbsoluteThickness[3],#]&/@ColorData[68,"ColorList"]),AspectRatio->1,FrameLabel->{"k","(Subscript[w, i])/(Subscript[x, i])"},LabelStyle->Directive[FontFamily->"Helvetica", FontSize-> 15],PlotRange->{{1,Length[xi]},{0,1.3}},Frame->True,Axes->False,ImageSize->430,FrameTicks->{{{0,0.4,0.8,1.2},None},{Automatic,None}}]}]}],{k,1,Length[xi],10}]]

(*to estimate the degree of matching*)
nijs=xi[[Length[xi]]];
nij={};
Table[If[i≠k,AppendTo[nij,Log[nijs[[k]]/nijs[[i]]]]],{i,1,Length[Nod]},{k,1,Length[Nod]}];
wij={};
Table[If[i≠k,AppendTo[wij,Log[wi[[k]]/wi[[i]]]]],{i,1,Length[Nod]},{k,1,Length[Nod]}];
PerfMatching=Table[{i,i},{i,-2,4}];
c=ListLinePlot[Table[{PerfMatching[[i,1]],PerfMatching[[i,2]]},{i,7}],PlotStyle->{Dashed,Thickness[0.004]},Frame->True,Axes->True,PlotRange->{{-1,1},{-1,1}},AspectRatio->1];
data=Table[{wij[[i]],nij[[i]]},{i,1,Length[nij]}];
line=Fit[data,{1,x},x]
Show[ListPlot[data,AspectRatio->1,ImageSize->470,PlotStyle->{Blue},PlotMarkers->{"·"},FrameLabel->{"Log((Subscript[𝓌, i])/(Subscript[𝓌, j]))","Log((Subscript[𝓍, i])/(Subscript[𝓍, j]))"},LabelStyle->Directive[FontFamily->"Helvetica", FontSize-> 15],BaseStyle->{FontSize->42},PlotRange->{{-1,1},{-1,1}},Frame->{{True,True},{True,True}}],c,Plot[{line},{x,-1,1},PlotStyle->{Red,Thickness[0.005]}]]