# How to explode set of lists into subsets under criterion?

Consider the following example set

set = { {a,{1,2,3}} , {b,{1}} , {c,{2,3}} , {d,{4,5}} , {e,{5}} };


I would like to have a function (lets call it magic[x_]) that looks at the lists set[[i,2]] and groups the elements i of set into new sets such as to separate disjoint lists. For example:

magic[set]


{ { {a,{1,2,3}} , {b,{1}} , {c,{2,3}} } , { {d,{4,5}} , {e,{5}} } }

which grouped elemets containing lists with overlapping entries {1,2,3} and {4,5} but each disjoint from one another. Is there a function in Mathematica which can be used to achieve that? Or maybe this can be implemented conveniently? Thanks for any suggestion!

• I'm not sure I understand what you want exactly, but does this work? Gather[set, IntersectingQ[#1[[2]], #2[[2]]] &]. It works for your example, but does it work for more general sets? Feb 9, 2017 at 18:54
• Wow, yes this works! I did not expect it to be this simple. Just out of curiosity, how do you think would one implement it if it had to be done in a more low level programming language? Feb 9, 2017 at 18:57
• That's a question for Stackoverflow. Feb 9, 2017 at 19:00
• @Feyre oh, ok, I understand. Feb 9, 2017 at 19:01
• @Kagaratsch To implement connected components directly, using Mathematica, see the first link here. Feb 9, 2017 at 19:56

"Overlapping" is not an equivalence relationship because it is not transitive. So approaches using Gather and related functions are not possible.

The simplest, though not the most efficient way is to test every pair of elements from the set. After doing that, we can treat this as a ConnectedComponents problem.

Code:

set = {{a, {1, 2, 3}}, {b, {1}}, {c, {2, 3}}, {d, {4, 5}}, {e, {5}}};

am = Outer[Boole@IntersectingQ[#1[[2]], #2[[2]]] &, set, set, 1]
(* {{1, 1, 1, 0, 0}, {1, 1, 0, 0, 0}, {1, 0, 1, 0, 0}, {0, 0, 0, 1, 1}, {0, 0, 0, 1, 1}} *)

(* {{1, 2, 3}, {4, 5}} *)

Part[set, #] & /@ components
(* {{{a, {1, 2, 3}}, {b, {1}}, {c, {2, 3}}}, {{d, {4, 5}}, {e, {5}}}} *)


This is what could happen if we try to use Gather anyway:

sets = Partition[Range[5], 2, 1]
(* {{1, 2}, {2, 3}, {3, 4}, {4, 5}} *)

Gather[sets, IntersectingQ]
(* { {{1, 2}, {2, 3}},
{{3, 4}, {4, 5}} } *)

• I suspected something of this sort. Is there an obvious example for which the simple Gather[set, IntersectingQ[#1[[2]], #2[[2]]] &] doesn't work? (And as a side note, you imply that Gather assumes transitivity, which means that it does not test every pair? Rather, I imagine it basically makes the sublists on the fly, and for each new check, it just checks to see if one of the elements already in the sublist matches with the new element. Is this correct?) Feb 9, 2017 at 19:54
• @march I think that is correct, see edit. Feb 9, 2017 at 19:58
• Thanks for the update. That's an important thing that definitely passed me by. Feb 10, 2017 at 18:47
ConnectedComponents @ SimpleGraph @ RelationGraph[IntersectingQ @@ {##}[[All, 2]]&, set]


{{{a, {1, 2, 3}}, {b, {1}}, {c, {2, 3}}},
{{d, {4, 5}}, {e, {5}}}}