Files
@ 3e647eb7b5b3
Branch filter:
Location: AENC/switchchain/triangle_creation_frequency_plots.m
3e647eb7b5b3
3.4 KiB
application/vnd.wolfram.mathematica.package
Add improved construction rate dataset and plot
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | (* ::Package:: *)
Needs["ErrorBarPlots`"]
(* ::Section:: *)
(*Data import*)
gsraw=Import[NotebookDirectory[]<>"data/graphdata_timeevol.m"];
(* gsraw=SortBy[gsraw,{#[[1,1]]&,#[[1,2]]&}]; (* Sort by n and then by tau. The {} forces a *stable* sort because otherwise Mathematica sorts also on triangle count and other things. *) *)
gdata=GatherBy[gsraw,{#[[1,2]]&,#[[1,1]]&}];
(* Data format: *)
(* gdata[[ tau index, n index, run index , datatype index ]] *)
(* datatype index:
1: {n,tau}
2: #triangles time sequence
3: degree sequence
*)
nlabels=Map["n = "<>ToString[#]&,gdata[[1,All,1,1,1]]];
taulabels=Map["tau = "<>ToString[#]&,gdata[[All,1,1,1,2]]];
(* Get the runs that have the same degree sequence *)
gdata2=GatherBy[gsraw,{#[[1,2]]&,#[[1,1]]&,#[[3]]&}];
(* gdata[[ tau index, n index, ds run index, MC run index , datatype index ]] *)
(* ::Section:: *)
(*Triangle creation frequencies*)
(* ::Subsection:: *)
(*Plot triangle count over "time" in Markov chain instances*)
numPlots=20;
selectedData=gdata[[1,1]][[-numPlots;;-1]];
measureSkip=1;
minCount=Min[Map[Min[#[[2]]]&,selectedData]];
maxCount=Max[Map[Max[#[[2]]]&,selectedData]];
maxTime=Max[Map[Length[#[[2]]]&,selectedData]];
(* maxTime=30000; *)
skipPts=Max[1,Round[maxTime/500]]; (* Plotting every point is slow. Plot only once per `skipPts` timesteps *)
coarseData=Map[#[[2,1;;maxTime;;skipPts]]&,selectedData];
labels=Map["{n,tau} = "<>ToString[#[[1]]]&,selectedData];
ListPlot[coarseData,Joined->True,PlotRange->{0*minCount,maxCount},DataRange->{0,measureSkip*maxTime},PlotLegends->labels]
(* Map[ListPlot[#,Joined->True,PlotRange\[Rule]{minCount,maxCount},DataRange\[Rule]{0,maxTime}]&,coarseData] *)
differences=Map[Differences[#[[2,25000;;-1]]]&,gdata2,{4}];
differences=Map[Flatten,differences,{3}];
(* For each (n,tau) take 2 degree sequences *)
histograms1=Map[Histogram[#[[{2,1}]],{-25.5,25.5,1},{"Log","Probability"},ImageSize->280]&,differences,{2}];
(* For each (n,tau) take the average over all degree sequences *)
histograms2=Map[Histogram[Flatten[#],{-3.5,3.5,1},"Probability",PlotRange->{0,1},LabelingFunction->(Placed[NumberForm[#,{2,3}],Above]&),ImageSize->280]&,differences,{2}];
TableForm[histograms2,TableHeadings->{taulabels,nlabels}]
{h1,h2,h3}={
Show[histograms1[[2]],PlotLabel->"n=1000, \[Tau]=2.2"],
Show[histograms1[[5]],PlotLabel->"n=1000, \[Tau]=2.5"],
Show[histograms1[[8]],PlotLabel->"n=1000, \[Tau]=2.8"]};
{h1zoomed,h2zoomed,h3zoomed}={
Show[histograms2[[2]],PlotLabel->"n=1000, \[Tau]=2.2"],
Show[histograms2[[5]],PlotLabel->"n=1000, \[Tau]=2.5"],
Show[histograms2[[8]],PlotLabel->"n=1000, \[Tau]=2.8"]};
hcol=GraphicsGrid[Transpose[{{h1,h2,h3},{h1zoomed,h2zoomed,h3zoomed}}]]
Export[NotebookDirectory[]<>"plots/triangle_creation_frequencies_log.pdf",hcol]
(* ::Subsection:: *)
(*Test with 'Callout' labels*)
createCalloutPlot[data_]:=Module[{h,hl,bcdata,llp},
h=Histogram[data,{-20.5,20.5,1},{"Log","Probability"},PlotRange->All,ImageSize->280];
hl=HistogramList[data,{-20.5,20.5,1},"Probability"];
bcdata=Map[If[#>=0.01,Callout[#,NumberForm[#,{2,3}]],Clip[#,{10^-5,2}]]&,hl[[2]]];
llp=ListLogPlot[bcdata,PlotStyle->None,DataRange->{-20,20}];
Show[h,llp]
]
histograms3=Map[createCalloutPlot[Flatten[#]]&,differences,{2}];
(* TODO: Somehow the values of these histograms do not match the ones above!!! ????? *)
Show[histograms3[[2]],PlotLabel->"n=1000, \[Tau]=2.2"]
Show[histograms3[[5]],PlotLabel->"n=1000, \[Tau]=2.5"]
Show[histograms3[[8]],PlotLabel->"n=1000, \[Tau]=2.8"]
|