6
$\begingroup$

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.

$\endgroup$

5 Answers 5

4
$\begingroup$
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}}
$\endgroup$
2
  • 1
    $\begingroup$ +1, but why did you add the much longer first solution? $\endgroup$
    – eldo
    Sep 18 at 7:37
  • 2
    $\begingroup$ because it is much faster than the others:) $\endgroup$
    – kglr
    Sep 18 at 7:40
3
$\begingroup$

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]

Mathematica graphics

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

$\endgroup$
1
  • $\begingroup$ Nice! I thought I missed some built-in function. $\endgroup$
    – licheng
    Sep 18 at 2:34
3
$\begingroup$

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

$\endgroup$
2
$\begingroup$

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}}}}*)
$\endgroup$
2
$\begingroup$
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}}}

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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