Graph Likelihood

Author

Eric W. Weisstein
December 16, 2021

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/GraphLikelihood.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/GraphLikelihood.html.

©2021 Wolfram Research, Inc. except for portions noted otherwise

Sources

https://arxiv.org/abs/1304.3600

Construction

Explicit lists (generate list with full expansion and probability for each expansion)

LikelihoodStep[{g_System`Graph,p_}]:=Module[{n=VertexCount[g]},
(Function[s,{EdgeAdd[VertexAdd[g,n+1],UndirectedEdge[#,n+1]&/@s],p/Binomial[n,Length[s]]/(n+1)}]/@Subsets[Range[n]])
]

(*
LikelihoodStep[l_]:={#[[1,1]],Total[#[[All,2]]]}&/@SplitBy[SortBy[(* bug(260322) *)
Flatten[LikelihoodStep/@l,1],
EdgeList[#[[1]]]&
],First]
*)
LikelihoodStep[l_]:={#[[1,2]],Total[#[[All,-1]]]}&/@
SplitBy[Sort[{CanonicalForm[#[[1]]],#[[1]],#[[2]]}&/@Flatten[LikelihoodStep/@l,1]],First]
g[1]={{System`Graph[{1},{}],1}};
g[n_]:=g[n]=LikelihoodStep[g[n-1]]

Save

Do[Print[{i,Length[g[i]]//Timing,MaxMemoryUsed[]/10^9. GB}];
Put[g[i],"/home/usr2/eww/mma/Graphs/Nodes/Likelihood/Graphs_"<>ToString[i]<>".m"] n,{i,9}]

Recognize

Do[Print[{i,rec=Map[If[GraphQ[#],RecognizeGraph[Evaluate@#,"Indexed"->False],#]&,g[i],{-1}];//Timing}];
Put[DeleteCases[rec,{{},_}],"/home/usr2/eww/mma/Graphs/Nodes/Likelihood/GraphNames_"<>ToString[i]<>".m"],{i,8}]

Arrays (store probabilities in-place)

counts={1,2,4,11,34,156,1044,12346,274668,12005168};

LikelihoodStep[g_System`Graph]:=Module[{n=VertexCount[g],p},p=like[n][[GraphIndex[g]]];
Function[s,array[[GraphIndex[EdgeAdd[VertexAdd[g,n+1],UndirectedEdge[#,n+1]&/@s]]]]+=p/Binomial[n,Length[s]]/(n+1)]/@Subsets[Range[n]];]

like[1]={1};
Do[array=ConstantArray[0,counts[[n]]];
Print[
{
n,
First[LikelihoodStep/@Graphs[n-1];//Timing],
MaxMemoryUsed[]/10^9. GB,
like[n]=array;Length[like[n]],
ByteCount[like[n]]/10^9.GB,
Through[{Min,Max,Total}[like[n]]]
}
];
Put[like[n],"/home/usr2/eww/mma/Graphs/Nodes/Likelihood/Likelihoods_"<>ToString[n]<>".m"],
{n,2,9}
]

Total/@Array[like,9,2]

nodes10=(ind=Cases[GraphData[#,"StandardNames"],{10,x_}:>x][[1]];{#,like[10][[ind]]})&/@GraphData[10];

Length[nodes10]

Put[nodes10,"/home/usr2/eww/mma/Graphs/Nodes/Likelihood/GraphNames_10.m"]

Attempt at path algorithm

AllAdjacencyMatrices2[g_System`Graph]:=Module[{n=VertexCount[g],e=EdgeList[g],p},If[(p=Quiet[Check[Permutations[Range[n]],$Failed]])===$Failed,Return[p]];
Normal[AdjacencyMatrix[System`Graph[Range[n],e/.Thread[Range[n]->#]]]]&/@p]

{#,Tally[AllAdjacencyMatrices2[GraphData[#]]][[All,2]]}&/@GraphData[4]//Column

(#->GraphData[#,"|Aut|"])&/@GraphData[4]//Column

Grid[{#,GraphData[#,"|Aut|"],GraphData[#,"Likelihood"],MatrixForm/@Normal/@GraphData[#,"AdjacencyMatrices"]}&/@GraphData[4],Dividers->All,Alignment->Left]

(Subscript[P, 3])

GraphData["P3","Likelihood"]

GraphData["P3","Degrees"]

MatrixForm/@(a=AllAdjacencyMatrices[GraphData["P3"]])

MatrixPlot/@a

(1/(3!))((1/2)+1+(1/2))

1/Binomial[2,{1,2,1}]

Claw

GraphData["ClawGraph","Likelihood"]

GraphData["ClawGraph","Degrees"]

MatrixPlot/@(a=AllAdjacencyMatrices[GraphData["ClawGraph"]])

(1/(4!))((1/3)+(1/2)+(1/2)+(1/3))

(4,2)

GraphData[{4,2},"Likelihood"]

GraphData[{4,2},"Degrees"]

MatrixPlot/@(a=AllAdjacencyMatrices[GraphData[{4,2}]])

(1/(4!))(1+1+1)

(4,6)

GraphData[{4,6},"Likelihood"]

GraphData[{4,6},"Degrees"]

MatrixPlot/@(a=AllAdjacencyMatrices[GraphData[{4,6}]])

(1/(4!))((1/2)+(1/3)+(1/3)+(1/2))

(1/2)+(1/3)+(1/3)+(1/2)

(1/(4!))((1/2)+(1/2)+(1/2))

1/Binomial[3,{2,0,2,2}]

{(1/6),1,(1/6),(1/6)}//Total

Binomial[0,4]

Visualization

GraphicsGrid[Map[Show[GraphPlot[GraphData[#[[1]]],"VertexColor"->Directive[AbsolutePointSize[5],Red],"EdgeColor"->Black],PlotLabel->TextCell[Row[{Style[GraphData[#[[1]],"Name"],FontFamily->"Times",FontSlant->Italic]," ","(",#[[2]],")"},BaseStyle->FontFamily->"Times"],TextAlignment->Center,PageWidth->100]]&,Flatten[Partition[#,6,6,{1,1},{}]&/@Take[rec,4],1],{2}],Dividers->All,ImageSize->620]

Co-Likely

Column[({#[[1,1]],#[[All,2]]}&/@Select[SplitBy[Sort[Reverse/@#],First],Length[#]>1&])&/@Take[rec,5]]

Inequality

Select[GraphData["Likelihood","Defined"],!({n,aut,L}=GraphData[#,{"V","AutomorphismCount","Likelihood"}];1/(aut Product[Binomial[i-1,Floor[(i-1)/2]],{i,n}])≤L≤1/aut)&]

Product[Binomial[i-1,Floor[(i-1)/2]],{i,n}]

Table[Product[Binomial[i-1,Floor[(i-1)/2]],{i,n}],{n,8}]

Refine[Floor[(i-1)/2],Mod[i,2]==0]//Simplify

Product[Binomial[i-1,(1/2) (-2+i)],{i,n}]

Refine[Floor[(i-1)/2],Mod[i,2]==1]//Simplify

Product[Binomial[i-1,(1/2) (-1+i)],{i,n}]

Parametrized families

GraphDataCountTable["Likelihood",{}]

Andrasfai

seq=Table[GraphData[{"Andrasfai",n},"Likelihood"],{n,10}]

Antiprism

Entity["Graph",{"Antiprism",n}]["Likelihood"]

seq=Table[GraphData[{"Antiprism",n},"Likelihood"],{n,3,25}]

Apollonian

seq=Table[GraphData[{"Apollonian",n},"Likelihood"],{n,6}]

Barbell

seq=Table[GraphData[{"Barbell",n},"Likelihood"],{n,3,20}]

Bishop n×n

seq=Table[GraphData[{"Bishop",{n,n}},"Likelihood"],{n,10}]

BlackBishop n×n

seq=Table[GraphData[{"BlackBishop",{n,n}},"Likelihood"],{n,10}]

CocktailParty

seq=Table[GraphData[{"CocktailParty",n},"Likelihood"],{n,20}]

FindSequenceFunction[DeleteMissing@seq,n]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

Complete

Entity["Graph",{"Complete",n}]["Likelihood"]

seq=Table[GraphData[{"Complete",n},"Likelihood"],{n,20}]

FullSimplify[FindSequenceFunction[seq,n]]

Table[(1/(n!)),{n,20}]

CompleteBipartite m×n

Entity["Graph",{"CompleteBipartite",{m,n}}]["Likelihood"]

CompleteBipartite n×n

Entity["Graph",{"CompleteBipartite",{n,n}}]["Likelihood"]

seq=Table[GraphData[{"CompleteBipartite",{n,n}},"Likelihood"],{n,20}]

FindSequenceFunction[DeleteMissing@seq,n]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

seq Range[5]!^4

CompleteTripartite k×m×n

Entity["Graph",{"CompleteTripartite",{k,m,n}}]["Likelihood"]

CompleteTripartite n×n×n

Entity["Graph",{"CompleteTripartite",{n,n,n}}]["Likelihood"]

seq=Table[GraphData[{"CompleteTripartite",{n,n,n}},"Likelihood"],{n,10}]

FindSequenceFunction[DeleteMissing@seq,n]

Crown

seq=Table[GraphData[{"Crown",n},"Likelihood"],{n,3,20}]

FindSequenceFunction[DeleteMissing@seq,n-2]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

Cycle

Entity["Graph",{"Cycle",n}]["Likelihood"]

seq=Table[GraphData[{"Cycle",n},"Likelihood"],{n,3,20}]

Through[{Numerator,Denominator}[seq]]

FindSequenceFunction[DeleteMissing@seq,n-2]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

Empty

Entity["Graph",{"Empty",n}]["Likelihood"]

seq=Table[GraphData[{"Empty",n},"Likelihood"],{n,30}]

FindSequenceFunction[seq,n]//FullSimplify

FibonacciCube

seq=Table[GraphData[{"FibonacciCube",n},"Likelihood"],{n,15}]

FoldedCube

seq=Table[GraphData[{"FoldedCube",n},"Likelihood"],{n,2,10}]

Gear

seq=Table[GraphData[{"Gear",n},"Likelihood"],{n,3,20}]

Grid m×n

Entity["Graph",{"Grid",{m,n}}]["Likelihood"]

Grid n×n

Entity["Graph",{"Grid",{n,n}}]["Likelihood"]

seq=Table[GraphData[{"Grid",{n,n}},"Likelihood"],{n,10}]

Grid k×m×n

Entity["Graph",{"Grid",{k,m,n}}]["Likelihood"]

Grid n×n×n

Entity["Graph",{"Grid",{n,n,n}}]["Likelihood"]

seq=Table[GraphData[{"Grid",{n,n,n}},"Likelihood"],{n,10}]

HalvedCube

seq=Table[GraphData[{"HalvedCube",n},"Likelihood"],{n,10}]

Hanoi

seq=Table[GraphData[{"Hanoi",n},"Likelihood"],{n,5}]

Helm

seq=Table[GraphData[{"Helm",n},"Likelihood"],{n,3,20}]

Hypercube

Entity["Graph",{"Hypercube",n}]["Likelihood"]

seq=Table[GraphData[{"Hypercube",n},"Likelihood"],{n,0,10}]

FindSequenceFunction[DeleteMissing@seq,n+1]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

Keller

Entity["Graph",{"Keller",n}]["Likelihood"]

seq=Table[GraphData[{"Keller",n},"Likelihood"],{n,5}]

King n×n

seq=Table[GraphData[{"King",{n,n}},"Likelihood"],{n,10}]

Knight m×n

Entity["Graph",{"Knight",{m,n}}]["Likelihood"]

Knight n×n

Entity["Graph",{"Knight",{n,n}}]["Likelihood"]

seq=Table[GraphData[{"Knight",{n,n}},"Likelihood"],{n,20}]

FindSequenceFunction[DeleteMissing@seq,n]

Ladder

Entity["Graph",{"Ladder",n}]["Likelihood"]

seq=Table[GraphData[{"Ladder",n},"Likelihood"],{n,20}]

FindSequenceFunction[DeleteMissing@seq,n]

LadderRung

seq=Table[GraphData[{"LadderRung",n},"Likelihood"],{n,20}]

nd=Transpose[NumeratorDenominator[DeleteMissing@seq]]

Do[Print[{k,FindLinearRecurrence[Drop[seq,k]]//Head//Timing}],{k,0,5}]

FindSequenceFunction[DeleteMissing@seq,n]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

seq Range[15]!^4

MengerSponge

seq=Table[GraphData[{"MengerSponge",n},"Likelihood"],{n,3}]

MoebiusLadder

Entity["Graph",{"MoebiusLadder",n}]["Likelihood"]

seq=Table[GraphData[{"MoebiusLadder",n},"Likelihood"],{n,3,25}]

Mycielski

Entity["Graph",{"Mycielski",n}]["Likelihood"]

seq=Table[GraphData[{"Mycielski",n},"Likelihood"],{n,11}]

Odd

Entity["Graph",{"Odd",n}]["Likelihood"]

seq=Table[GraphData[{"Odd",n},"Likelihood"],{n,7}]

Path

Entity["Graph",{"Path",n}]["Likelihood"]

seq=Table[GraphData[{"Path",n},"Likelihood"],{n,20}]

FindSequenceFunction[DeleteMissing@seq,n]

Prism

Entity["Graph",{"Prism",n}]["Likelihood"]

seq=Table[GraphData[{"Prism",n},"Likelihood"],{n,3,25}]

Queen n×n

seq=Table[GraphData[{"Queen",{n,n}},"Likelihood"],{n,10}]

Rook n×n

seq=Table[GraphData[{"Rook",{n,n}},"Likelihood"],{n,10}]

RookComplement n×n

seq=Table[GraphData[{"RookComplement",{n,n}},"Likelihood"],{n,10}]

SierpinskiCarpet

seq=Table[GraphData[{"SierpinskiCarpet",n},"Likelihood"],{n,4}]

SierpinskiSieve

seq=Table[GraphData[{"SierpinskiSieve",n},"Likelihood"],{n,5}]

SierpinskiTetrahedron

seq=Table[GraphData[{"SierpinskiTetrahedron",n},"Likelihood"],{n,6}]

Star

Entity["Graph",{"Star",n}]["Likelihood"]

seq=Table[GraphData[{"Star",n},"Likelihood"],{n,25}]

FindSequenceFunction[DeleteMissing@seq,n]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

Table[Sum[i!,{i,0,n-1}],{n,7}]

Table[Piecewise[{{1/2,n==2}},(n/(((n!))^2))Sum[i!,{i,0,n-1}]],{n,10}]

FullSimplify[(n/(((n!))^2))Sum[i!,{i,0,n-1}],n∈Integers&&n>0]

FullSimplify[#,n∈Integers&&n>0]&/@Apart[%]

(n/(((n!))^2))Sum[i!,{i,0,n-1}]

Table[-((n Subfactorial[-1])/(((n!))^2))+(((((-1))^n)  Subfactorial[-1-n])/((n-1)!)),{n,10}]//FullSimplify

FullSimplify[-((n Subfactorial[-1])/(((n!))^2))+(((((-1))^n)  Subfactorial[-1-n])/((n-1)!)),n∈Integers&&n>0]

Table[-((n Subfactorial[-1])/(((n!))^2))+(((((-1))^n)  Subfactorial[-1-n])/((n-1)!)),{n,25}]//FunctionExpand//FullSimplify

Sun

seq=Table[GraphData[{"Sun",n},"Likelihood"],{n,3,20}]

Sunlet

seq=Table[GraphData[{"Sunlet",n},"Likelihood"],{n,3,20}]

Tetrahedral

seq=Table[GraphData[{"Tetrahedral",n},"Likelihood"],{n,6,10}]

TorusGrid n×n

seq=Table[GraphData[{"TorusGrid",{n,n}},"Likelihood"],{n,3,10}]

Transposition

Entity["Graph",{"Transposition",n}]["Likelihood"]

seq=Table[GraphData[{"Transposition",n},"Likelihood"],{n,6}]

Triangular

seq=Table[GraphData[{"Triangular",n},"Likelihood"],{n,2,10}]

TriangularGrid

seq=Table[GraphData[{"TriangularGrid",n},"Likelihood"],{n,10}]

Web

seq=Table[GraphData[{"Web",n},"Likelihood"],{n,3,20}]

Wheel

Entity["Graph",{"Wheel",n}]["Likelihood"]

seq=Table[GraphData[{"Wheel",n},"Likelihood"],{n,4,20}]

FindSequenceFunction[DeleteMissing@seq,n-3]//Head//Timing

FindGeneratingFunction[DeleteMissing@seq,x]//Head//Timing

WhiteBishop n×n

seq=Table[GraphData[{"WhiteBishop",{n,n}},"Likelihood"],{n,2,10}]

Compute for n Edges

Matching with n edges

nedges=Select[GraphData[All],MatchQ[DeleteCases[Tally[GraphData[#,"Degrees"]],{0,_}],{{1,_}}]&]

(#->GraphData[#])&/@nedges

SortBy[nedges,GraphData[#,"M"]&]

LikelihoodNEdges[n_,s_]:=Module[{a,i,solns},
a=Array[i,s];
solns=a/.{ToRules[Reduce[Inequality[2,LessEqual,Sequence@@Riffle[a,Less],LessEqual,n],a,Integers]]};
Total[Function[f,Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,f]]/@solns]/n!
]

SolutionSet1[n_,s_]:=Module[{a,i,solns},
a=Array[i,s];
solns=a/.{ToRules[Reduce[Inequality[2,LessEqual,Sequence@@Riffle[a,Less],LessEqual,n],a,Integers]]}
]

SolutionSet2[n_,s_]:=Module[{a,i,solns},
a=Array[i,s];
Flatten[Table[a,{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]],s-1]
]

s1=SolutionSet1[9,4]

s2=SolutionSet2[9,4]

s1==s2

LikelihoodNEdgesReduce

Print[{#,GraphData[#,{"V","M"}],LikelihoodNEdges@@GraphData[#,{"V","M"}]//Timing,GraphData[#,"Likelihood"]}]&/@Take[SortBy[nedges,GraphData[#,"M"]&],All];

LikelihoodNEdgesTable (faster)

LikelihoodNEdges2[n_,s_]:=Module[{a,i,solns},
a=Array[i,s];
solns=Flatten[Table[a,{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]],s-1];
Total[Function[f,Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,f]]/@solns]/n!
]

Print[{#,GraphData[#,{"V","M"}],LikelihoodNEdges2@@GraphData[#,{"V","M"}]//Timing,GraphData[#,"Likelihood"]}]&/@Cases[SortBy[nedges,GraphData[#,"M"]&],{"LadderRung",_}];

LikelihoodNEdgesLoop (still faster)

LikelihoodNEdgesLoop[n_,s_]:=Module[{i,k,sum=0},
Do[sum+=Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,Array[i,s]],{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]
];
sum/n!
]

LikelihoodNEdgesLoop@@GraphData[{"LadderRung",11},{"V","M"}]//Timing

Print[{#,GraphData[#,{"V","M"}],LikelihoodNEdges2@@GraphData[#,{"V","M"}]//Timing,GraphData[#,"Likelihood"]}]&/@Cases[SortBy[nedges,GraphData[#,"M"]&],{"LadderRung",_}];

LikelihoodNEdgesLoopCompiled

cf=Compile[{{i,_Integer}},Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,i]]

LikelihoodNEdgesLoopCompiled[n_,s_]:=Module[{i,k,sum=0},
Do[sum+=cf@Array[i,s],{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]
];
sum/n!
]

LikelihoodNEdgesLoopCompiled@@GraphData[{"LadderRung",2},{"V","M"}]//Timing

Print[{#,GraphData[#,{"V","M"}],LikelihoodNEdges2@@GraphData[#,{"V","M"}]//Timing,GraphData[#,"Likelihood"]}]&/@Cases[SortBy[nedges,GraphData[#,"M"]&],{"LadderRung",_}];

LikelihoodNEdgesParallelSum (can’t compile)

LikelihoodNEdgesParallelSum[n_,s_]:=Module[{i,k},
ParallelSum[Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,Array[i,s]],{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]
]/n!
]

LikelihoodNEdgesParallelSum@@GraphData[{"LadderRung",6},{"V","M"}]//Timing

LikelihoodNEdges2[n_,s_]:=Module[{a,i,solns},
a=Array[i,s];
solns=Flatten[Table[a,{i[1],2,n-s+1},Evaluate[Sequence@@Table[{i[k],i[k-1]+1,n-s+k},{k,2,s}]]],s-1];
Total[Function[f,Times@@MapIndexed[((#+1-2#2[[1]])/(#-1))&,f]]/@solns]/n!
]

Print[{#,GraphData[#,{"V","M"}],LikelihoodNEdges2@@GraphData[#,{"V","M"}]//Timing,GraphData[#,"Likelihood"]}]&/@Cases[SortBy[nedges,GraphData[#,"M"]&],{"LadderRung",_}];

Matching with 1 edge

oneedge=Select[GraphData[All],DeleteCases[Tally[GraphData[#,"Degrees"]],{0,_}]==={{1,2}}&]

(#->GraphData[#])&/@oneedge

{#,GraphData[#,"Likelihood"],With[{n=GraphData[#,"V"]},((n-1)/(n!))]}&/@twoedges

Matching with 2 edges

twoedges=Select[GraphData[All],DeleteCases[Tally[GraphData[#,"Degrees"]],{0,_}]==={{1,4}}&]

GraphData/@twoedges

(1/(n!))Sum[-1-i+n+2 PolyGamma[0,i]-i PolyGamma[0,i]+i PolyGamma[0,1+i]-2 PolyGamma[0,n],{i,2,n-1}]//FullSimplify

FullSimplify[((6-7 n+(n^2)+4 (EulerGamma+PolyGamma[0,n]))/(2 n!)),n∈Integers&&n>0]

Factor[6-7 n+(n^2)]

(( (n-1)(n-6)+4 (EulerGamma+PolyGamma[0,n]))/(2 n!))/.n->5

{#,With[{n=GraphData[#,"V"]},((6-7 n+(n^2)+4 (EulerGamma+PolyGamma[0,n]))/(2 n!))]}&/@twoedges

Table[((6-7 n+(n^2)+4 (EulerGamma+PolyGamma[0,n]))/(2 n!)),{n,10}]

Table[(((n-1)(n-6)+4 HarmonicNumber[n-1])/(2 n!)),{n,10}]

FullSimplify[(((n-1)(n-6)+4 HarmonicNumber[n-1])/(2 n!))]

Matching with 3 edges

edges3=Select[GraphData[All],DeleteCases[Tally[GraphData[#,"Degrees"]],{0,_}]==={{1,6}}&]

GraphData/@edges3

With[{n=6,s=3},(1/(n!))Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i1,2,n-s+1},{i2,i1+1,n-s+2},{i3,i2+1,n}]]//Timing

GraphData[{"LadderRung",3},"Likelihood"]

With[{n=18,s=3},(1/(n!))Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i1,2,n-s+1},{i2,i1+1,n-s+2},{i3,i2+1,n}]]//Timing

GraphData[{"Fiveleaper",{3,6}},"Likelihood"]

(1/(n!))Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i1,2,n-s+1},{i2,i1+1,n-s+2},{i3,i2+1,n}]//FullSimplify//Timing

With[{s=3},Table[Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i1,2,n-s+1},{i2,i1+1,n-s+2},{i3,i2+1,n}],{n,10}]]

s==3

Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i3,i2+1,n}]//FullSimplify

Sum[-(((-3+i2) (i2-n-4 PolyGamma[0,i2]+4 PolyGamma[0,n]))/(-1+i2)),{i2,i1+1,n-1}]//Timing

Apart[-(((-3+i2) (i2-n-4 PolyGamma[0,i2]+4 PolyGamma[0,n]))/(-1+i2))]

Sum[(((-3+i2) (i2-n-4 PolyGamma[0,i2]))/(-1+i2)),{i2,i1+1,n-1}]

Sum[((4 (-3+i2) PolyGamma[0,n])/(-1+i2)),{i2,i1+1,n-1}]//FullSimplify

Sum[((i2-3)/(i2-1))((i3-5)/(i3-1)),{i1,2,n-s+1},{i2,i1+1,n-s+2},{i3,i2+1,n}]/

Distributions of Values

Length/@(likelihood=Prepend[Table[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","Likelihood","Likelihoods_"<>ToString[n]<>".m"}]],{n,2,10}],{1}])//Timing

Plots

GraphicsGrid[Partition[ListPlot[Sort[likelihood[[#]]],PlotRange->All,PlotLabel->Style[n==#,FontFamily->"Times"],TicksStyle->FontFamily->"Times"]&/@Range[2,9],3,3,{1,1},{}],ImageSize->600]

Total

Total[likelihood,{2}]//Timing

Mean

https://oeis.org/A000088

(μ=Mean/@likelihood)//Timing

Through[{Numerator,Denominator}[μ]]

Min

min=Min/@likelihood

Through[{Numerator,Denominator}[min]]

PickExtrema[n_,f_]:=Module[{l=likelihood[[n]],m},
m=f[l];
{n,m,Quiet[GraphData[{n,#},"#"]&/@Flatten[Position[l,m]]/.GraphData[x_,_]:>x]}
]

Grid[min=Table[PickExtrema[n,Min],{n,2,10}],Dividers->All,Alignment->{{Right,Center,Left},Automatic}]

Table[{Floor[n/2],Ceiling[n/2]},{n,2,10}]

Table[RecognizeGraph@System`CompleteGraph[{Floor[n/2],Ceiling[n/2]}],{n,2,10}]

Grid[{#[[1]],GraphData/@#[[3]]}&/@min/.GraphData[{n_,k_}]:>Graphs[n][[k]],Dividers->All,Alignment->{{Center,Left},Automatic}]//Quiet

Max

max=Max/@likelihood

Through[{Numerator,Denominator}[max]]

Grid[max=Table[PickExtrema[n,Max],{n,2,10}],Dividers->All,Alignment->{{Right,Center,Left},Automatic}]

Grid[{#[[1]],GraphData/@#[[3]]}&/@max/.GraphData[{n_,k_}]:>Graphs[n][[k]],Dividers->All,Alignment->{{Center,Left},Automatic}]//Quiet