Connected Graph

Author

Eric W. Weisstein
November 9, 2022

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

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

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

Simple Graphs

Counts

Should be 1, 1, 1, 2, 6, 21, 112, 853, 11117, 261080, … (OEIS A001349)

Table[Count[#,_?ConnectedQ]&/@Graphs/@Range[9]]//Timing

Length/@(connected=ConnectedGraphs/@Range[9])//Timing

Enumeration

ShowGraphArray[Flatten[Partition[#,10,10,{1,1},{}]&/@connected,1],
VertexStyle->Disk[.16],
VertexColor->Red,
GraphicsSpacing->{.5,.4}]

Connected Graphs w/ Minimum Degree 2

Timing[Length/@(connected2=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥2&]],connected,{1}])]

Timing[Length/@(connected2=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥2&]],connected,{1}])]

ShowGraphArray[Flatten[Partition[#,6,6,{1,1},{}]&/@connected2,1],
VertexStyle->Disk[.16],
VertexColor->Red,
GraphicsSpacing->{.5,.4}]

Connected Graphs w/ Minimum Degree 3

Timing[Length/@(connected3=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥3&]],connected2,{1}])]

ShowGraphArray[Flatten[Partition[#,7,7,{1,1},{}]&/@Take[connected3,6],1],
VertexStyle->Disk[.16],
VertexColor->Red,
GraphicsSpacing->{.5,.4}]

Connected Graphs w/ Minimum Degree 4

Timing[Length/@(connected4=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥4&]],connected3,{1}])]

ShowGraphArray[Flatten[Partition[#,10,10,{1,1},{}]&/@Take[connected4,7],1],
VertexStyle->Disk[.16],
VertexColor->Red
]

Connected Graphs w/ Minimum Degree 5

Timing[Length/@(connected5=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥5&]],connected4,{1}])]

ShowGraphArray[Flatten[Partition[#,10,10,{1,1},{}]&/@Take[connected5,7],1],
VertexStyle->Disk[.16],
VertexColor->Red
]

Connected Graphs w/ Minimum Degree 6

Timing[Length/@(connected6=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥6&]],connected5,{1}])]

ShowGraphArray[Flatten[Partition[#,10,10,{1,1},{}]&/@Take[connected6,8],1],
VertexStyle->Disk[.16],
VertexColor->Red
]

Connected Graphs w/ Minimum Degree 7

Timing[Length/@(connected7=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥7&]],connected6,{1}])]

ShowGraphArray[Flatten[Partition[#,10,10,{1,1},{}]&/@connected7,1],
VertexStyle->Disk[.16],
VertexColor->Red
]

Connected Graphs w/ Minimum Degree 8

Timing[Length/@(connected8=Map[Function[f,Select[f,Min[DegreeSequence[#]]≥8&]],connected7,{1}])]

Algorithms

Mathematica StackExchange (@user293787 method)

https://mathematica.stackexchange.com/questions/275779/how-to-create-all-possible-graphs-that-connect-all-vertices

allEdges[n_]:=Flatten[Table[UndirectedEdge[i,j],{i,n},{j,i+1,n}]];
ConnectedLabeledGraphs[n_]:=Select[
Map[Graph[Range[n],#]&,Subsets[allEdges[n]]],
ConnectedGraphQ]
AllConnectedGraphs[n_]:=DeleteDuplicatesBy[AllConnectedLabeledGraphs[n],CanonicalGraph]

Do[
Print[{n,AllConnectedGraphs[n]//Length//Timing}],
{n,7}]

Converting edges to a Graph and calling ConnectedGraphQ

isolatedfree=Select[GraphData[;;20],GraphData[#,"IsolatedPoints"]==={}&];

DeleteCases[{#,GraphData[#,"Connected"],ConnectedGraphQ[Graph[GraphData[#,"EdgeList"]]]}&/@isolatedfree,{_,x_,x_}]//Timing

If Connected, TotalVertexDegree > (n-1)/2 (but TotalVertexDegree > (n-1)/2 could be connected or disconnected)

dataloose={#,GraphData[#,"Connected"],Total[GraphData[#,"VertexDegrees"]]>=(GraphData[#,"V"]-1)/2}&/@GraphData[;;15];

datastrict={#,GraphData[#,"Connected"],Total[GraphData[#,"VertexDegrees"]]>(GraphData[#,"V"]-1)/2}&/@GraphData[;;15];

These graphs don't satisfy the inequality (they are all disconnected):

Cases[dataloose,{g_,_,False}:>g]

Cases[datastrict,{g_,_,False}:>g]

The singleton graph is the only connected graph which does not satisfy the strict criterion:

Cases[datastrict,{g_,True,False}:>g]

Cases[dataloose,{g_,True,False}:>g]

With[{g=CompleteGraph[1]},{Total[VertexDegree[g]]>(VertexCount[g]-1)/2,ConnectedGraphQ[g]}]

With[{g=CompleteGraph[1]},{Total[VertexDegree[g]]>=(VertexCount[g]-1)/2,ConnectedGraphQ[g]}]

Disconnected graphs that do not satisfy the criterion:

Cases[datastrict,{g_,False,False}:>g]

Cases[dataloose,{g_,False,False}:>g]

With[{g=GraphData["P2+4K1"]},{
Total[VertexDegree[g]],
(VertexCount[g]-1)/2,
Total[VertexDegree[g]]>(VertexCount[g]-1)/2,
Total[VertexDegree[g]]>=(VertexCount[g]-1)/2,
ConnectedGraphQ[g]}]

With[{g=GraphDisjointUnion@@CompleteGraph/@{2,1,1,1,1}},{Total[VertexDegree[g]],(VertexCount[g]-1)/2}]

So most disconnected graphs actually satisfy the inequality:

Cases[datastrict,{g_,False,True}:>g]

With[{g=GraphDisjointUnion@@CompleteGraph/@{2,1}},Total[VertexDegree[g]]>=(VertexCount[g]-1)/2]

Cases[datastrict,{g_,_,False}:>g]

Using Adjacency Matrix

If A is the adjacency matrix, then entry (i,j) of A^k is the number of k-walks from vertex i to vertex j, so the n-vertex graph defined by A is connected iff A^1+A^2+...+A^(n-1) has no entries equal to zero.

ConnectedGraphViaAdjacencyMatrixQ[a_]:=Times@@Flatten[Total[NestList[Dot[a,#]&,a,Length[a]-1]]]!=0

DeleteCases[{#,GraphData[#,"Connected"],ConnectedGraphViaAdjacencyMatrixQ[GraphData[#,"AdjacencyMatrix"]]}&/@GraphData[;;20],{_,x_,x_}]//Timing

DeleteCases[{#,GraphData[#,"Connected"],ConnectedGraphViaAdjacencyMatrixQ[GraphData[#,"AdjacencyMatrix"]]}&/@isolatedfree,{_,x_,x_}]//Timing

Converting edges to AdjacencyMatrix

DeleteCases[{#,GraphData[#,"Connected"],ConnectedGraphViaAdjacencyMatrixQ[AdjacencyMatrix[GraphData[#,"EdgeList"]]]}&/@isolatedfree,{_,x_,x_}]//Timing

DFS using edge lists

connectedQ[edges_]:=connectedQ[DeleteDuplicates[Join@@List@@@edges],edges]
connectedQ[vertices_,edges:{__}]:=Equal@@Length/@{vertices,Reap[DepthFirstScan[edges,edges[[1,1]],{"DiscoverVertex"->(Sow[#1]&)}]][[2,1]]}

DeleteCases[{#,GraphData[#,"Connected"],connectedQ[GraphData[#,"EdgeList"]]}&/@isolatedfree,{_,x_,x_}]//Timing

DFS using edge indices

connectedQ[edges_]:=connectedQ[DeleteDuplicates[Flatten[edges]],edges]
connectedQ[vertices_,edges:{__}]:=Length[vertices]===Length[Reap[DepthFirstScan[edges,edges[[1,1]],{"DiscoverVertex"->(Sow[#]&)}]][[2,1]]]

DeleteCases[{#,GraphData[#,"Connected"],connectedQ[GraphData[#,"EdgeIndices"]]}&/@isolatedfree,{_,x_,x_}]//RepeatedTiming

connectedQ2[edges_]:=connectedQ2[DeleteDuplicates[Flatten[edges]],edges]
connectedQ2[vertices_,edges_]:=Length[vertices]===Length[Reap[DepthFirstScan[edges,edges[[1,1]],{"DiscoverVertex"->(Sow[#]&)}]][[2,1]]]

DeleteCases[{#,GraphData[#,"Connected"],connectedQ2[GraphData[#,"EdgeIndices"]]}&/@isolatedfree,{_,x_,x_}]//RepeatedTiming

connectedQ3[edges_]:=connectedQ3[Union[Flatten[edges]],edges]
connectedQ3[vertices_,edges_]:=Length[vertices]===Length[Reap[DepthFirstScan[edges,edges[[1,1]],{"DiscoverVertex"->(Sow[#]&)}]][[2,1]]]

DeleteCases[{#,GraphData[#,"Connected"],connectedQ3[GraphData[#,"EdgeIndices"]]}&/@isolatedfree,{_,x_,x_}]//RepeatedTiming