# How to choose three vertices having maximum number of interconnecting edges?

I have a set of edges as follows:

edges = {{1, 5}, {1, 72}, {5, 72}, {1, 7}, {1, 59}, {7, 59}, {1, 8}, {1,
45}, {8, 45}, {1, 10}, {1, 73}, {10, 73}, {1, 12}, {1, 18}, {12,
18}, {1, 13}, {1, 15}, {13, 15}, {1, 15}, {1, 29}, {15, 29}, {1,
19}, {1, 22}, {19, 22}, {1, 28}, {1, 35}, {28, 35}, {1, 37}, {1,
38}, {37, 38}, {1, 43}, {1, 52}, {43, 52}, {1, 48}, {1, 67}, {48,
67}, {1, 59}, {1, 71}, {59, 71}, {2, 3}, {2, 51}, {3, 51}, {2,
7}, {2, 36}, {7, 36}, {2, 11}, {2, 67}, {11, 67}, {2, 13}, {2,
56}, {13, 56}, {2, 17}, {2, 64}, {17, 64}, {2, 18}, {2, 35}, {18,
35}, {2, 20}, {2, 25}, {20, 25}, {2, 20}, {2, 37}, {20, 37}, {2,
20}, {2, 74}, {20, 74}, {2, 24}, {2, 35}, {24, 35}, {2, 26}, {2,
49}, {26, 49}, {2, 30}, {2, 42}, {30, 42}, {2, 32}, {2, 67}, {32,
67}, {2, 37}, {2, 49}, {37, 49}, {2, 40}, {2, 47}, {40, 47}, {3,
4}, {3, 74}, {4, 74}, {3, 13}, {3, 51}, {13, 51}, {3, 14}, {3,
70}, {14, 70}, {3, 16}, {3, 45}, {16, 45}, {3, 18}, {3, 45}, {18,
45}, {3, 30}, {3, 63}, {30, 63}, {3, 31}, {3, 65}, {31, 65}, {3,
44}, {3, 45}, {44, 45}, {4, 5}, {4, 29}, {5, 29}, {4, 6}, {4,
9}, {6, 9}, {4, 6}, {4, 67}, {6, 67}, {4, 10}, {4, 74}, {10,
74}, {4, 12}, {4, 60}, {12, 60}, {4, 13}, {4, 69}, {13, 69}, {4,
16}, {4, 24}, {16, 24}, {4, 18}, {4, 55}, {18, 55}, {4, 19}, {4,
65}, {19, 65}, {4, 28}, {4, 39}, {28, 39}, {4, 32}, {4, 55}, {32,
55}, {4, 32}, {4, 64}, {32, 64}, {4, 33}, {4, 62}, {33, 62}, {4,
43}, {4, 50}, {43, 50}, {4, 51}, {4, 70}, {51, 70}, {4, 56}, {4,
71}, {56, 71}, {5, 9}, {5, 12}, {9, 12}, {5, 9}, {5, 61}, {9,
61}, {5, 10}, {5, 48}, {10, 48}, {5, 20}, {5, 61}, {20, 61}, {5,
21}, {5, 67}, {21, 67}, {5, 24}, {5, 75}, {24, 75}, {5, 32}, {5,
45}, {32, 45}, {5, 41}, {5, 45}, {41, 45}, {5, 41}, {5, 53}, {41,
53}, {5, 44}, {5, 51}, {44, 51}, {5, 48}, {5, 53}, {48, 53}, {5,
49}, {5, 64}, {49, 64}, {5, 53}, {5, 61}, {53, 61}, {6, 7}, {6,
69}, {7, 69}, {6, 10}, {6, 62}, {10, 62}, {6, 12}, {6, 56}, {12,
56}, {6, 12}, {6, 58}, {12, 58}, {6, 12}, {6, 75}, {12, 75}, {6,
17}, {6, 69}, {17, 69}, {6, 18}, {6, 32}, {18, 32}, {6, 18}, {6,
44}, {18, 44}, {6, 20}, {6, 51}, {20, 51}, {6, 29}, {6, 52}, {29,
52}};


Now I wish to chose 3 vertices v1 v2 and v3 such that there exists at least one edge between any two of these vertices and the number of edges among these 3 vertices is maximum. I can get the frequencies as follows:

frequencies = ReverseSortBy[Tally@edges, Last];


which gives me

{{{6, 12}, 3}, {{5, 61}, 3}, {{5, 53}, 3}, {{3, 45}, 3}, {{2, 20},
3}, {{6, 69}, 2}, {{6, 18}, 2}, {{5, 48}, 2}, {{5, 45},
2}, {{5, 41}, 2}, {{5, 9}, 2}, {{4, 74}, 2}, {{4, 55}, 2}, {{4, 32},
2}, {{4, 6}, 2}, {{3, 51}, 2}, {{2, 67}, 2}, {{2, 49},
2}, {{2, 37}, 2}, {{2, 35}, 2}, {{1, 59}, 2}, {{1, 15},
2}, {{59, 71}, 1}, {{56, 71}, 1}, {{53, 61}, 1}, {{51, 70},
1}, {{49, 64}, 1}, {{48, 67}, 1}, {{48, 53}, 1}, {{44, 51},
1}, {{44, 45}, 1}, {{43, 52}, 1}, {{43, 50}, 1}, {{41, 53},
1}, {{41, 45}, 1}, {{40, 47}, 1}, {{37, 49}, 1}, {{37, 38},
1}, {{33, 62}, 1}, {{32, 67}, 1}, {{32, 64}, 1}, {{32, 55},
1}, {{32, 45}, 1}, {{31, 65}, 1}, {{30, 63}, 1}, {{30, 42},
1}, {{29, 52}, 1}, {{28, 39}, 1}, {{28, 35}, 1}, {{26, 49},
1}, {{24, 75}, 1}, {{24, 35}, 1}, {{21, 67}, 1}, {{20, 74},
1}, {{20, 61}, 1}, {{20, 51}, 1}, {{20, 37}, 1}, {{20, 25},
1}, {{19, 65}, 1}, {{19, 22}, 1}, {{18, 55}, 1}, {{18, 45},
1}, {{18, 44}, 1}, {{18, 35}, 1}, {{18, 32}, 1}, {{17, 69},
1}, {{17, 64}, 1}, {{16, 45}, 1}, {{16, 24}, 1}, {{15, 29},
1}, {{14, 70}, 1}, {{13, 69}, 1}, {{13, 56}, 1}, {{13, 51},
1}, {{13, 15}, 1}, {{12, 75}, 1}, {{12, 60}, 1}, {{12, 58},
1}, {{12, 56}, 1}, {{12, 18}, 1}, {{11, 67}, 1}, {{10, 74},
1}, {{10, 73}, 1}, {{10, 62}, 1}, {{10, 48}, 1}, {{9, 61},
1}, {{9, 12}, 1}, {{8, 45}, 1}, {{7, 69}, 1}, {{7, 59},
1}, {{7, 36}, 1}, {{6, 75}, 1}, {{6, 67}, 1}, {{6, 62},
1}, {{6, 58}, 1}, {{6, 56}, 1}, {{6, 52}, 1}, {{6, 51},
1}, {{6, 44}, 1}, {{6, 32}, 1}, {{6, 29}, 1}, {{6, 20},
1}, {{6, 17}, 1}, {{6, 10}, 1}, {{6, 9}, 1}, {{6, 7}, 1}, {{5, 75},
1}, {{5, 72}, 1}, {{5, 67}, 1}, {{5, 64}, 1}, {{5, 51},
1}, {{5, 49}, 1}, {{5, 44}, 1}, {{5, 32}, 1}, {{5, 29},
1}, {{5, 24}, 1}, {{5, 21}, 1}, {{5, 20}, 1}, {{5, 12},
1}, {{5, 10}, 1}, {{4, 71}, 1}, {{4, 70}, 1}, {{4, 69},
1}, {{4, 67}, 1}, {{4, 65}, 1}, {{4, 64}, 1}, {{4, 62},
1}, {{4, 60}, 1}, {{4, 56}, 1}, {{4, 51}, 1}, {{4, 50},
1}, {{4, 43}, 1}, {{4, 39}, 1}, {{4, 33}, 1}, {{4, 29},
1}, {{4, 28}, 1}, {{4, 24}, 1}, {{4, 19}, 1}, {{4, 18},
1}, {{4, 16}, 1}, {{4, 13}, 1}, {{4, 12}, 1}, {{4, 10}, 1}, {{4, 9},
1}, {{4, 5}, 1}, {{3, 74}, 1}, {{3, 70}, 1}, {{3, 65},
1}, {{3, 63}, 1}, {{3, 44}, 1}, {{3, 31}, 1}, {{3, 30},
1}, {{3, 18}, 1}, {{3, 16}, 1}, {{3, 14}, 1}, {{3, 13}, 1}, {{3, 4},
1}, {{2, 74}, 1}, {{2, 64}, 1}, {{2, 56}, 1}, {{2, 51},
1}, {{2, 47}, 1}, {{2, 42}, 1}, {{2, 40}, 1}, {{2, 36},
1}, {{2, 32}, 1}, {{2, 30}, 1}, {{2, 26}, 1}, {{2, 25},
1}, {{2, 24}, 1}, {{2, 18}, 1}, {{2, 17}, 1}, {{2, 13},
1}, {{2, 11}, 1}, {{2, 7}, 1}, {{2, 3}, 1}, {{1, 73}, 1}, {{1, 72},
1}, {{1, 71}, 1}, {{1, 67}, 1}, {{1, 52}, 1}, {{1, 48},
1}, {{1, 45}, 1}, {{1, 43}, 1}, {{1, 38}, 1}, {{1, 37},
1}, {{1, 35}, 1}, {{1, 29}, 1}, {{1, 28}, 1}, {{1, 22},
1}, {{1, 19}, 1}, {{1, 18}, 1}, {{1, 13}, 1}, {{1, 12},
1}, {{1, 10}, 1}, {{1, 8}, 1}, {{1, 7}, 1}, {{1, 5}, 1}}


By observation {6, 12} has 3 edges and the next sorted occurrence of 6 or 12 is {6, 69} which has 2 edges, however, {12, 69} has no edge. For {5, 61}, the next occurrence is {5, 53} and both have 3 edges each and also there is an edge connecting {53, 61}. How can I choose these three variables {5, 53, 61}?

• Are you simply looking for triangles? Apr 7, 2020 at 15:49
• @HenrikSchumacher Not really. Triangulation is one criterion as indicated in the question. On top of that, I need to find out that triangle whose vertices have the maximum number of interconnecting edges. Apr 7, 2020 at 16:00
• So, finding all triangles would already be a first step, right? Szabolcs' package "IGraphM" provides the function that can do that. Apr 7, 2020 at 16:13

You can use FindCycle and Subgraph:

g = Graph[UndirectedEdge @@@ edges];


Convert it to a simple graph since multiplicity doesn't necessary for this.

triangles = FindCycle[SimpleGraph[g], {3}, All];

subgraphs = Subgraph[g, #, AnnotationRules -> None] & /@ triangles;
VertexList[First[MaximalBy[subgraph, EdgeCount]]]


{5, 53, 61}

or

MaximalBy[triangles,
EdgeCount[Subgraph[g, #, AnnotationRules -> None]] &]


{{5 \[UndirectedEdge] 53, 53 \[UndirectedEdge] 61, 61 \[UndirectedEdge] 5}}

I would do it like this with IGraph/M:

Create a graph:

g = Graph[UndirectedEdge @@@ edges];


Merge parallel edges and record the multiplicities as edge weights:

wg = IGWeightedSimpleGraph[g];


Now we find the maximum total edge weight triangle:

MaximalBy[
IGTriangles[g],
Total@IGEdgeProp[EdgeWeight]@IGWeightedSubgraph[wg, #] &
]

(* {{5, 61, 53}} *)


This will work in Mathematica 10.0 and later.

In Mathematica 12.0 or later, you can use Subgraph instead of IGWeightedSubgraph, as it does preserve weights.

A bit more complicated than @halmir's version, but I wanted to show how to work with edge weights. The main advantage of this answer is that IGTriangles is faster than FindCycle (because it is more specialized).

Note: You may be thinking of this problem as finding maximum-weight 3-cliques. IGraph/M does have a function called IGWeightedCliques, but it works with vertex-weights, not edge-weights. I am noting this just to avoid confusion.

You can employ Szabolcs' package "IGraphM" to find all triangles first (if there are any). Then finding the a triangle with maximal number of edges attached to it is straight-forward:

Needs["IGraphM"]
G = Graph[Range[Max[edges]], UndirectedEdge @@@ edges];
triangles = IGTriangles[G];
i = Ordering[Total[Partition[VertexDegree[G][[Flatten[triangles]]], 3], {2}], -1][[1]];
triangles[[i]]

• Hm. Please restart the kernel. Could be that this clash stems from the installation process of "IGraphM"... Apr 7, 2020 at 16:36
• Hm ... I think this is incorrect. The vertex degre you compute is in the entire graph, but we want to maximize the number of edges in the 3-vertex subgraph (triangle). Apr 7, 2020 at 17:31
• Can you clarify what clash you are referring to? I you just upgraded the package, please do restart the kernel. I am having trouble unloading the LibraryLink component recently, not sure why ... thus a kernel restart is necessary after installing a new version on most platforms. Apr 7, 2020 at 17:32
• @Szabolcs Majis told me that Mathematica gave the shadowing warning for IGTriangle. Seemingly, a kernel restart indeed solved it. Apr 7, 2020 at 17:39
• Ah, it was just shadowing. Apr 7, 2020 at 17:41

Hint.

With Version 10

sedges = Sort[edges]
sant   = Min[edges];
cont   = Table[0, Max[sedges]]

For[i = 1, i <= Length[sedges], i++, se = sedges[[i]];
If[se[[1]] == sant, cont[[sant]]++, cont[[se[[1]]]]++];
sant = se[[1]]
]


Now cont has the incidences per knot in increasing order. After that

FindShortestPath[edges, 2, 4]
FindShortestPath[edges, 4, 1]
FindShortestPath[edges, 1, 2]

• I do not understand how this obtains the result {{5, 61, 53}}. Apr 7, 2020 at 19:46
• After the Sort we have the edges sorted by the first knot. After the For we have how many edges are connected to any knot. It gives for cont the values $\{26,30,17,33,28,22,\cdots.,\}$ Those number of "visits" are regarding the knots $\{1,2,3,4,5,\cdots,\}$ now with FindShortestPath we can find if the most visited knots are connected by a path etc. Apr 7, 2020 at 20:21