Discover overlapping sublists within a list

Question

Given a list, for example, L = {{1, 2, 4}, {8, 3, 5}, {5, 6, 8}, {1, 7, 4}}, some of these sublists have common elements, such as {1, 2, 4} and {1, 7, 4}. I only need to find one pair. So, I have written the following code.

L = {{1, 2, 4}, {8, 3, 5}, {5, 6, 8}, {1, 7, 4}};
result = Select[Subsets[L, {2}], IntersectingQ[#[[1]], #[[2]]] &, 1]

But I feel like the function Subsets (generating too many of them) is a bit overkill. In reality, we will quickly find them in my large list, and I only need to find one pair. I wonder if there is a better function to achieve this.

Answer 1

L = {{1, 2, 4}, {8, 3, 5}, {5, 6, 8}, {1, 7, 4}};

1.

Cases[L, {___, SelectFirst[Tally[Join @@ L], #[[2]] >= 2 &][[1]], ___}]

{{1, 2, 4}, {1, 7, 4}}

2.

DeleteDuplicates[L, DisjointQ]

{{1, 2, 4}, {1, 7, 4}}

3.

Union[L, SameTest -> DisjointQ]

{{1, 2, 4}, {1, 7, 4}}

Answer 2

I only need to find one pair.

Since you want to stop just on finding the first overlap, why not iterate over the list? This is worst case is O(n^2) algorithm

findit[L_List] := Module[{n, m},
  Do[Do[
    If[IntersectingQ[L[[n]], L[[m]]],
     Return[{L[[n]], L[[m]]}, Module]
     ],
    {n, m + 1, Length[L]}
    ],
   {m, 1, Length[L] - 1}
   ];
   {}
  ]

L = {{1, 2, 4}, {8, 3, 5}, {5, 6, 8}, {1, 7, 4}};
findit[L]

You could do timings on large list and compare performance with what you have.

Answer 3

Using Position:

L = {{1, 2, 4}, {8, 3, 5}, {5, 6, 8}, {1, 7, 4}};
pos = Position[L, #, {2}] & /@ (Union @@ L) /. {_List} :> 
     Nothing /. {a_?IntegerQ, b_?IntegerQ} :> a // Union
L[[#]] & /@ pos

Using Tuples:

Tuples[L, 2] /. {a_, a_} :> Nothing /. {a_, b_} /; DisjointQ[a, b] :> 
    Nothing // Map[Sort] // DeleteDuplicates

Using Outer:

Pick[L, #, False] & /@ Outer[DisjointQ, L, L, 1] // DeleteDuplicates

or

Pick[L, #] & /@ Outer[IntersectingQ, L, L, 1] // DeleteDuplicates

---

Result

{{{1, 2, 4}, {1, 7, 4}}, {{8, 3, 5}, {5, 6, 8}}}

Answer 4

Please consider the execution time:

Select[Subsets[L, {2}], IntersectingQ[#[[1]], #[[2]]] &] // RepeatedTiming

(*{0.000223486, {{{1, 2, 4}, {1, 7, 4}}, {{8, 3, 5}, {5, 6, 8}}}}*)

Select[Subsets[lst, {2}], Length[Intersection @@ #] > 0 &] // RepeatedTiming

(*{0.000026016, {{{1, 2, 4}, {1, 7, 4}}, {{8, 3, 5}, {5, 6, 8}}}}*)

Answer 5

Delete[#, Position[{}] @ MapApply[Intersection] @ #] & [Subsets[list, {2}]]

{{{1, 2, 4}, {1, 7, 4}}, {{8, 3, 5}, {5, 6, 8}}}

Extract[#, Position[{{_}, _}] @ Map[UniqueElements] @ #] & @ Subsets[list, {2}]

{{{1, 2, 4}, {1, 7, 4}}, {{8, 3, 5}, {5, 6, 8}}}