# Find Lists with intersecting sublists

I have a list of the following form:

l = {{"label1", {1, 2, 3}}, {"label2", {4, 5}},
{"label3", {3, 6, 9, 8}}, {"label4", {11, 25, 24, 14}}, {"lable5", {4, 5}}}


I would like to retrieve only those labels whose corresponding list has an intersection with the corresponding list of another label, along with the intersecting elements. So, for l I would get

{{"label1", "label2", "label3", "label5"}, {3, 4, 5}}


(I'll add my answer, but I'd like to see if someone can come up with a simpler one)

• What are the constraints, if any, on contents? Is the list target always of the example format? Are the sublist values always positive integer, and if so, is there some reasonable limit on max values? Do you envision huge lists, or are the problem sizes small (like the example)?
– ciao
Jun 15, 2014 at 23:25
• @rasher The list is always in the example format and the problem size is relatively small (no more than 10 or 20 labels, with few elements in each sublist), but the sublist values could be integers or strings Jun 16, 2014 at 2:16
• In that case, other than a terse code war, your solution is fine - plenty fast for such short lists. Interesting problem, nonetheless, when thinking about large lists. +1 on the question!
– ciao
Jun 16, 2014 at 2:27

Perhaps a little "simpler", and a little quicker for smallish lists (it will blow up time-wise as list lengths grow, as does the OP method,) :

With[{i = Intersection @@@ Subsets[#[[All, 2]], {2}]}, {Union @@
Pick[Subsets[#[[All, 1]], {2}], # != {} & /@ i], Union @@ i}] &@l


I'll throw this done while lounging quickie into the ring. It assumes the constraints I asked about in the comments hold (sublist values are positive integers) though if that's not the case it could be easily adapted to handle it. Not simpler, but certainly faster as list size grows.

intersectionInfo=
Module[{s = SparseArray[Join @@ Thread /@ Transpose[{Range@Length@#, #[[All, 2]]}] -> 1],
vals, lbls},
vals = Pick[Range@Max@#[[All, 2]], UnitStep[Subtract[Total[s], 2]], 1];
lbls = #[[All, 1]][[Pick[Range@Length@s, Unitize[Total /@ s[[All, vals]]], 1]]];
{lbls, vals}] &;

(* use your example l *)
intersectionInfo@l

(* {{"label1", "label2", "label3", "lable5"}, {3, 4, 5}} *)


A quick run using a 5000 length list generated with

len = 5000;
l = Range@len;
subs = DeleteDuplicates /@ RandomInteger[{1, 10000}, {len, 5}];
l = Transpose[{l, subs}];


shows about a 700:1 performance advantage (grows as list size grows). N.B.: I used integer labels for convenience in the test, should have no material effect on timing differences.

The solution I've come up with is to first do

l = {{"label1", {1, 2, 3}}, {"label2", {4, 5}},
{"label3", {3, 6, 9, 8}}, {"label4", {11, 25, 24, 14}}, {"lable5", {4, 5}}}

x = Select[l, MemberQ[#[[2]],
Alternatives @@ Flatten[DeleteCases[l, #][[All, 2]]]] &]


to get the elements with intersections, then using

{ x[[All, 1]], Select[Gather@Flatten@x[[All, 2]], Length[#] > 1 &][[All, 1]] }


to get the correct format

• What is z in the second block? Is that supposed to be x?
– ciao
Jun 15, 2014 at 23:17
• oh, yeah, thanks Jun 15, 2014 at 23:22