How Do I Gather All Intersecting Lists?

Question

So, I have a list of pairs:

list = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 10}, {10, 
11}, {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, {3, 15}, {15, 
1}};

Graph@list view:

I need to gather all pairs that have a common element. I thought this is the way to do it:

gathered = Gather[list, IntersectingQ]

Which outputs:

{{{1, 2}, {2, 3}, {15, 1}}, {{4, 5}, {5, 6}, {14, 4}}, {{7, 8}, {8, 9}, {13, 7}}, {{9, 10}, {10, 11}}, {{11, 12}, {12, 13}}, {{6, 14}}, {{3, 15}}}

That's 7 lists, please note {3,15} was supposed to end up in the first one. What is the proper way to do it, so I get what I expect, which is:

{{{1, 2}, {2, 3}, {15, 1}, {3, 15}}, {{4, 5}, {5, 6}, {14, 4}, {6, 14}}, {{9, 10}, {10, 11}, {11, 12}, {12, 13}, {7, 8}, {8, 9}, {13, 7}}}

,which is 3 lists with all intersecting pairs?

NB!

Edited: solutions summarized in my

answer below.

Answer 1

You can use RelationGraph, e.g.

list = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 10}, {10, 
    11}, {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, {3, 15}, {15, 
    1}};
r = RelationGraph[IntersectingQ[#1, #2] && #1 != #2 &, list]
VertexList /@ ConnectedGraphComponents[r]

{{{7, 8}, {8, 9}, {13, 7}, {9, 10}, {12, 13}, {10, 11}, {11, 
   12}}, {{4, 5}, {5, 6}, {14, 4}, {6, 14}}, {{1, 2}, {2, 3}, {15, 
   1}, {3, 15}}}

Would need modification depending on specific needs, esp for different lists.

Or a slight variant using DistanceMatrix and custom DistanceFunction and then same graph functions:

m = DistanceMatrix[list, 
    DistanceFunction -> (Length[Intersection[#1, #2]] &)] /. 2 -> 0;
list[[VertexList[#]]] & /@ ConnectedGraphComponents[AdjacencyGraph[m]]

Answer 2

list = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 10}, {10, 
    11}, {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, {3, 15}, {15, 
    1}};

DeleteCases[(ConnectedGraphComponents[list] // Map[EdgeList]) /. 
  UndirectedEdge -> List // Map[SortBy[First]],{}]

---

{{{7, 8}, {8, 9}, {9, 10}, {10, 11}, {11, 12}, {12, 13}, {13, 7}}, {{4, 5}, {5, 6}, {6, 14}, {14, 4}}, {{1, 2}, {2, 3}, {3, 15}, {15, 1}}}

Answer 3

This is pretty clunky/klugey, I think, but here's a way to do it using iterative Gather list manipulations. (I include this mainly to point out why Gather doesn't work on its own: it's because Gather seems to assume that the function used to detect equality is an equivalence relation, and the one outlined in the OP is not.)

list = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 10}, {10, 11},
    {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, {3, 15}, {15, 1}};
FixedPoint[
   Flatten[#, 1] & /@ Gather[#, Or @@ Flatten@Outer[IntersectingQ, #1, #2, 1] &] &,
   List /@ list
  ]
(* {{{1, 2}, {2, 3}, {15, 1}, {3, 15}},
    {{4, 5}, {5, 6}, {14, 4}, {6, 14}},
    {{7, 8}, {8, 9}, {13, 7}, {9, 10}, {10, 11}, {11, 12}, {12, 13}}} *)

The issue with using one Gather command is that it seems to assume that the test function that goes in the second slot is transitive. However, IntersectingQ is a non-transitive relation, since {1,2} intersects {2,3} which in turn intersects {3,4}, but {1,2} and {3,4} don't intersect. Gather doesn't seem to "back-check" its gathered lists; that is, it goes through the list sequentially, and once it's Gathered an element, it doesn't then use that element to check against the other elements in the list.

This version iteratively Gathers elements by checking to see if any list in the already-Gathered list intersects any element of another of the already-Gathered lists, combining them if so. The Outer command is the one that checks all two-element lists against each other, the Flatten command turns the Gathered list back into a list of ordered pairs. Finally, FixedPoint makes the process recursive, and stops once the output doesn't change anymore.

It is beyond likely that using the built-in graph functionality will be much faster.

Answer 4

Solution V1.0: Naive Approach

list={{1,2},{2,3},{4,5},{5,6},{7,8},{8,9},{9,10},{10,11},{11,12},{12,13},{13,7},{6,14},{14,4},{3,15},{15,1}};

antonV10naive=ConnectedComponents@list/.Join[AssociationThread[list[[All, 1]]->list],AssociationThread[list[[All, 2]]->list]]

{{{13, 7}, {7, 8}, {12, 13}, {8, 9}, {11, 12}, {9, 10}, {10, 11}}, {{14, 4}, {4, 5}, {6, 14}, {5, 6}}, {{15, 1}, {1, 2}, {3, 15}, {2, 3}}}

As pointed out by @vindobona, this solution breaks down with list like this:

listVindobona = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 
10}, {10, 11}, {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, {3, 
15}, {15, 1}, {1, 99}};

@lericr discovered that it also breaks in two special cases:

listlericr1 = {{1, 2}, {1, 3}, {2, 3}, {4, 5}, {5, 6}};(* creates duplicate {4,5} *)

listlericr2 = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {3, 4}};(* looses the {1,3} pair *)

Solution V1.2: Issues Fixed

To address these three issues, the improved v1.2 approach was developed:

antonV12fixed=Map[DeleteDuplicates@Flatten[#,1]&,WeaklyConnectedComponents[Rule@@@list]/.Merge[{PositionIndex[list[[All,1]]],PositionIndex[list[[All,2]]]},Flatten]/.AssociationThread[Range@Length@list->list]]

Solution V2.0 - Alternative Solution

This one relies on Nearest. It's pretty fast but not as fast as v1.2. or @vindobona 's solution.

Map[list[[DeleteDuplicates[Flatten[#]]]]&,Ceiling[Map[Nearest[Flatten@list->"Index",#]&,WeaklyConnectedComponents[Rule@@@list]]*.5]]

Solution V3.0: using GroupBy

This is so far the fastest way I've found:

Map[Union@Flatten[#,1]&,WeaklyConnectedComponents[Rule@@@list]/.Merge[{GroupBy[list,First],GroupBy[list,Last]},Flatten[#,1]&]]

Testing & Timings

listVindobona={{1,2},{2,3},{4,5},{5,6},{7,8},{8,9},{9,10},{10,11},{11,12},{12,13},{13,7},{6,14},{14,4},{3,15},{15,1},{1,99}};
listlericr1={{1,2},{1,3},{2,3},{4,5},{5,6}};
listlericr2={{1,2},{1,3},{1,4},{2,3},{3,4}};

list=listVindobona;

{t1,ubpdqn}=VertexList/@ConnectedGraphComponents[RelationGraph[IntersectingQ[#1,#2]&&#1!=#2&,list]]//RepeatedTiming;

{t2,Syed}=DeleteCases[(ConnectedGraphComponents[list]//Map[EdgeList])/.UndirectedEdge->List//Map[SortBy[First]],{}]//RepeatedTiming;

{t3,march}=FixedPoint[Flatten[#,1]&/@Gather[#,Or@@Flatten@Outer[IntersectingQ,#1,#2,1]&]&,List/@list]//RepeatedTiming;

{t4,antonV12}=Map[DeleteDuplicates@Flatten[#,1]&,WeaklyConnectedComponents[Rule@@@list]/.Merge[{PositionIndex[list[[All,1]]],PositionIndex[list[[All,2]]]},Flatten]/.AssociationThread[Range@Length@list->list]]//RepeatedTiming;

{t5,lericr}=DeleteCases[Apply[List,EdgeList/@ConnectedGraphComponents@list,{2}],{}]//RepeatedTiming;

{t6,antonV20}=Map[list[[DeleteDuplicates[Flatten[#]]]]&,Ceiling[Map[Nearest[Flatten@list->"Index",#]&,WeaklyConnectedComponents[Rule@@@list]]*.5]]//RepeatedTiming;

connectedPairs[list_]:=With[{ds=CreateDataStructure["DisjointSet"]},ds["InsertAll",Flatten@list];Map[ds["Unify",Sequence@@#]&,list];Map[s|->Select[ds["CommonSubsetQ",#[[1]],s]&]@list,ds["Subsets"][[All,1]]]];
{t7,vindobona}=connectedPairs[list]//RepeatedTiming;

{t8,antonV30}=Map[Union@Flatten[#,1]&,WeaklyConnectedComponents[Rule@@@list]/.Merge[{GroupBy[list,First],GroupBy[list,Last]},Flatten[#,1]&]]//RepeatedTiming;
Sort[Sort/@antonV12]==Sort[Sort/@antonV20]==Sort[Sort/@ubpdqn]==Sort[Sort/@Syed]==Sort[Sort/@march]==Sort[Sort/@lericr]==Sort[Sort/@vindobona]==Sort[Sort/@antonV30]

True

Performance At Scale:

I've tested all algos with

list=Complement[Union[Sort/@RandomInteger[{1,n},{n,2}]],Transpose[{r=Range@n,r}]];

,with n being equal to 20, 50, 100, 500 and 1000.

Answer 5

This is just a slight correction (at least as I understood the problem) to the answer provided by the OP, @Anton. It is a very nice strategy, but it doesn't generalize and it doesn't reconstruct the connected components correctly according to the original list. For reference, here is @Anton's general strategy for a given list of pairs:

ConnectedComponents@list /. 
  Join[
    AssociationThread[list[[All, 1]] -> list],
    AssociationThread[list[[All, 2]] -> list]]

Not generalizable

Let's say our list of pairs looks like this:

list = {{1, 2}, {1, 3}, {2, 3}, {10, 11}}

When we interpret this as edges of a graph, we will end up with vertices 4,5,6,7,8,9 just because of the default way WL builds graphs.

ConnectedComponents@list
(* {{1, 2, 3}, {10, 11}, {9}, {8}, {7}, {6}, {5}, {4}} *)

ConnectedComponents@list /. Join[AssociationThread[list[[All, 1]] -> list], AssociationThread[list[[All, 2]] -> list]]
(* {{{1, 3}, {1, 2}, {2, 3}}, {{10, 11}, {10, 11}}, {9}, {8}, {7}, {6}, {5}, {4}} *)

Creates duplicates

Given

list = {{1, 2}, {1, 3}, {2, 3}, {4, 5}, {5, 6}}

ConnectedComponents@list
(* {{4, 5, 6}, {1, 2, 3}} *)

ConnectedComponents@list /. Join[AssociationThread[list[[All, 1]] -> list], AssociationThread[list[[All, 2]] -> list]]
(* {{{4, 5}, {4, 5}, {5, 6}}, {{1, 3}, {1, 2}, {2, 3}}} *)

Notice that {4, 5} is duplicated in the result. It might be that in the OP's data this case never occurs, but if so that wasn't made clear.

Doesn't recover all pairs

Consider this case:

list = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {3, 4}};

ConnectedComponents@list
(* {{1, 2, 3, 4}} *)

ConnectedComponents@list /. Join[AssociationThread[list[[All, 1]] -> list], AssociationThread[list[[All, 2]] -> list]]
(* {{{1, 4}, {1, 2}, {2, 3}, {3, 4}}} *)

Notice we've lost {1, 3}. Since ReplaceAll works on the list of connected vertices, anytime we have more edges than vertices, we'll lose edges.

Improved version

Let's keep the idea of using connected components, but since we're interpreting our original list of pairs as edges of a graph, it would be nice if we could use the built-in EdgeList function for graphs to recover the edges in the connected components. We can do this if we could get the connected components as graphs themselves. Fortunately, that's what ConnectedGraphComponents does.

list = {{1, 2}, {1, 3}, {2, 3}, {4, 5}, {5, 6}};
ConnectedGraphComponents@list

EdgeList /@ ConnectedGraphComponents@list

We can recover the pairs with

Apply[List, EdgeList /@ ConnectedGraphComponents@list, {2}]
(* {{{1, 2}, {1, 3}, {2, 3}, {1, 4}, {3, 4}}} *)

or alternatively with

EdgeList /@ ConnectedGraphComponents@list /. UndirectedEdge -> List

Let's apply this to our other test case:

list = {{1, 2}, {1, 3}, {2, 3}, {10, 11}};
EdgeList /@ ConnectedGraphComponents@list

Okay, we should eliminate the empty lists. I'll do it at the very end of the process:

DeleteCases[Apply[List, EdgeList /@ ConnectedGraphComponents@list, {2}], {}]
(* {{{1, 2}, {1, 3}, {2, 3}}, {{10, 11}}} *)

Applying this to the original list:

list = {{1, 2}, {2, 3}, {4, 5}, {5, 6}, {7, 8}, {8, 9}, {9, 10}, 
        {10, 11}, {11, 12}, {12, 13}, {13, 7}, {6, 14}, {14, 4}, 
        {3, 15}, {15, 1}};
DeleteCases[Apply[List, EdgeList /@ ConnectedGraphComponents@list, {2}], {}]
(* {{{7, 8}, {13, 7}, {8, 9}, {12, 13}, {9, 10}, {10, 11}, {11, 12}},
    {{4, 5}, {14, 4}, {5, 6}, {6, 14}}, 
    {{1, 2}, {15, 1}, {2, 3}, {3, 15}}} *)

I kept the DeleteCases for generality, it isn't strictly necessary in this case.

Answer 6

Just another version using DisjointSet DataStructure :

connectedPairs[list_] :=
  With[{ds = CreateDataStructure["DisjointSet"]},
    ds["InsertAll", Flatten@list];
    Map[ds["Unify", Sequence @@ #] &, list];
    Map[s |-> Select[ds["CommonSubsetQ", #[[1]], s] &]@list, ds["Subsets"][[All, 1]]]]

list=
  {{1,2},{2,3},{4,5},{5,6},{7,8}
  ,{8,9},{9,10},{10,11},{11,12},{12,13}
  ,{13,7},{6,14},{14,4},{3,15},{15,1},{1,99}};

connectedPairs[list] 

(*
  {{{1,2},{2,3},{3,15},{15,1},{1,99}}
  ,{{4,5},{5,6},{6,14},{14,4}}
  ,{{7,8},{8,9},{9,10},{10,11},{11,12},{12,13},{13,7}}}}
*)

Answer 7

List @@@ # &@*EdgeList /@ ConnectedGraphComponents@list

Or if for some reason not to use ConnectedGraphComponents.

Partition[#, 2] & @@@ 
 FixedPoint[Gather[Flatten /@ #, IntersectingQ] &, list]