7
$\begingroup$

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!

$\endgroup$
  • 2
    $\begingroup$ 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? $\endgroup$ – march Feb 9 '17 at 18:54
  • $\begingroup$ 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? $\endgroup$ – Kagaratsch Feb 9 '17 at 18:57
  • 1
    $\begingroup$ That's a question for Stackoverflow. $\endgroup$ – Feyre Feb 9 '17 at 19:00
  • $\begingroup$ @Feyre oh, ok, I understand. $\endgroup$ – Kagaratsch Feb 9 '17 at 19:01
  • 1
    $\begingroup$ @Kagaratsch To implement connected components directly, using Mathematica, see the first link here. $\endgroup$ – Szabolcs Feb 9 '17 at 19:56
8
$\begingroup$

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

components = ConnectedComponents@AdjacencyGraph[am]
(* {{1, 2, 3}, {4, 5}} *)

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

Addendum

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}} } *)
$\endgroup$
  • $\begingroup$ 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?) $\endgroup$ – march Feb 9 '17 at 19:54
  • $\begingroup$ @march I think that is correct, see edit. $\endgroup$ – Szabolcs Feb 9 '17 at 19:58
  • $\begingroup$ Thanks for the update. That's an important thing that definitely passed me by. $\endgroup$ – march Feb 10 '17 at 18:47
2
$\begingroup$
ConnectedComponents @ SimpleGraph @ RelationGraph[IntersectingQ @@ {##}[[All, 2]]&, set]

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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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