5
$\begingroup$

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}?

$\endgroup$
  • $\begingroup$ Are you simply looking for triangles? $\endgroup$ – Henrik Schumacher Apr 7 at 15:49
  • $\begingroup$ @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. $\endgroup$ – Majis Apr 7 at 16:00
  • $\begingroup$ So, finding all triangles would already be a first step, right? Szabolcs' package "IGraphM`" provides the function that can do that. $\endgroup$ – Henrik Schumacher Apr 7 at 16:13
5
$\begingroup$

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}}

| improve this answer | |
$\endgroup$
4
$\begingroup$

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.

| improve this answer | |
$\endgroup$
3
$\begingroup$

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]]
| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ Hm. Please restart the kernel. Could be that this clash stems from the installation process of "IGraphM`"... $\endgroup$ – Henrik Schumacher Apr 7 at 16:36
  • $\begingroup$ 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). $\endgroup$ – Szabolcs Apr 7 at 17:31
  • $\begingroup$ 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. $\endgroup$ – Szabolcs Apr 7 at 17:32
  • $\begingroup$ @Szabolcs Majis told me that Mathematica gave the shadowing warning for IGTriangle. Seemingly, a kernel restart indeed solved it. $\endgroup$ – Henrik Schumacher Apr 7 at 17:39
  • $\begingroup$ Ah, it was just shadowing. $\endgroup$ – Szabolcs Apr 7 at 17:41
2
$\begingroup$

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]
| improve this answer | |
$\endgroup$
  • $\begingroup$ I do not understand how this obtains the result {{5, 61, 53}}. $\endgroup$ – Szabolcs Apr 7 at 19:46
  • $\begingroup$ 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. $\endgroup$ – Cesareo Apr 7 at 20:21

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.