Discover overlapping sublists within a list

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.

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

• +1, but why did you add the much longer first solution?
– eldo
Sep 18 at 7:37
• because it is much faster than the others:)
– kglr
Sep 18 at 7:40

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.

• Nice! I thought I missed some built-in function. Sep 18 at 2:34

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

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

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