23
$\begingroup$

I wonder if there is any simple way to split a list into its disjoint sublists, e.g. from

list={{a,b},{e,f},{b,c},{c,d},{f,g,h}}

get a result

listdis={{{a,b},{b,c},{c,d}},{{e,f},{f,g,h}}},

so that one gets disjoint sublists such that any element can be connected with another element through other elements inside that list (like a disjoint chains of elements).

Obviously sublists are of any length.

$\endgroup$
0

6 Answers 6

14
$\begingroup$

This is a standard connectivity problem. Here is a graph-based solution:

ClearAll[listToGraph];
listToGraph[list_List]:=
   Graph @ Union[
         Sort /@ Flatten[Apply[UndirectedEdge,(Partition[#1,2,1]&) /@ list,{2}]]
   ];


ClearAll[getConnectivityRules];
getConnectivityRules[graph_Graph]:=
   (Dispatch[Flatten[Thread /@ Thread[#1 -> Range[Length[#1]]]]]&)[
      ConnectedComponents[graph]
   ];


ClearAll[connectedComponents];
connectedComponents[list_List]:=
   With[{connectivityRules = getConnectivityRules @ listToGraph @ list},
      GatherBy[list,First[#1] /. connectivityRules&]
   ]

so that

connectedComponents[list]

(* {{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, g, h}}}  *)
$\endgroup$
4
  • $\begingroup$ This one needs a bit of improvement (Union[Sort/@edgelist]) to handle lists like this: list = {{a, b}, {b, a}, {c, d}}. $\endgroup$
    – Szabolcs
    Nov 18, 2013 at 19:00
  • $\begingroup$ This looks like a very good idea, to construct the graph over the sublist elements, and avoid having to do pairwise tests over sublists. I wonder what is the theoretically most efficient way for various kinds of inputs. $\endgroup$
    – Szabolcs
    Nov 18, 2013 at 19:09
  • $\begingroup$ @Szabolcs Re: improvement - thanks, nicely spotted. Done now. Re: most efficient way - this problem is discussed e.g. in the book of Robert Sedgewick, "Algorithms in C", I think, at the very start. He gives several algorithms, such as union-find algorithm (fast union of fast find). This can be a good place to start if you are interested, it is nicely explained there. $\endgroup$ Nov 18, 2013 at 19:22
  • $\begingroup$ @Szabolcs Actually, my translation of one of the algorithms from Sedgewick's book into Mathematica can be found in this thread, in which you did also participate, and from which Ray adopted Carl's answer, which he posted here. This was actually that historical thread, where the solution based on recursive pure functions was also developed. My fastest version there was in this post. $\endgroup$ Nov 19, 2013 at 13:20
9
$\begingroup$

Another graph-based solution:

Sort@Cases[#, _List] & /@ ConnectedComponents@
  Graph@Flatten[Thread@UndirectedEdge[ConstantArray[#, Length[#]], #] & /@ list]
{{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, g, h}}}

Here I construct the following graph

Graph[Thread@UndirectedEdge[ConstantArray[#, Length[#]], #] & /@ 
   list // Flatten, VertexLabels -> "Name"]

enter image description here

Then I find connected components and choose vertices with List head.

$\endgroup$
2
  • $\begingroup$ This one fails on list = RandomInteger[100, {100, 10}] due to multiple edges. $\endgroup$
    – Szabolcs
    Nov 18, 2013 at 19:03
  • $\begingroup$ @Szabolcs Good catch! One can add DeleteDuplicates but it is not very good. $\endgroup$
    – ybeltukov
    Nov 18, 2013 at 21:09
7
$\begingroup$

This is an adaptation of Carl Woll's aggs. It's less obvious but may be substantially faster for long lists. "cis" stands for "collect intersecting sublists".

cis[list_] := Module[{j,aj}, list[[#]]& /@
  SparseArray`StronglyConnectedComponents[ Sign[#.Transpose@# &
  @ SparseArray @ Thread[ Join@@( Function[{j,aj}, {j,#}& /@ Union@aj]
  @@@ Transpose@{Range@Length@list, list /. Thread[
  # -> Range@Length@#]& @ Union@Flatten@list} ) -> 1 ]]]]

cis[list]

(* {{{a,b},{b,c},{c,d}},{{e,f},{f,g,h}}} *)
$\endgroup$
3
  • $\begingroup$ +1. I actually published the Compile-based implementation on Mathgroup a while ago, which was beating Carl's code (although not by much), but it is much longer and I decided to not post it here. But this one is very nice. $\endgroup$ Nov 19, 2013 at 11:14
  • $\begingroup$ Thanks. I found your code here. $\endgroup$ Nov 19, 2013 at 16:46
  • $\begingroup$ Right...It's hard to believe it has been 4 years already, since that time. This was actually one of the more interesting threads. $\endgroup$ Nov 19, 2013 at 16:48
7
$\begingroup$

This is the same graph-based idea that other solution use, with a slightly shorter, and (to me) more intuitive implementation. Let's first make an adjacency matrix based on sublist intersections:

graph = AdjacencyGraph@Unitize@Outer[Composition[Length, Intersection], list, list, 1];

list[[#]] & /@ ConnectedComponents[graph]

(* ==> {{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, g, h}}} *)
$\endgroup$
1
  • 1
    $\begingroup$ You can specify vertex list when you construct adjacency graph: AdjacencyGraph[list, Sign@Outer[Composition[Length, Intersection], list, list, 1]] $\endgroup$
    – halmir
    Nov 18, 2013 at 18:44
3
$\begingroup$

In versions 10.2+, RelationGraph makes this task an easy one:

f = ConnectedComponents @ RelationGraph[IntersectingQ, #]&;
f @ list

{{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, g, h}}}

$\endgroup$
1
$\begingroup$

Appending unnecessary information can really help in this scenario,

Most[Rest[# //. {a___, {x__List}, b___} -> {a, x, 
       b} & /@ (FlattenAt[{{1}, ##, {2}} &[(Intersection[{{a, b}, {b, 
           c}, {c, d}, {e, f}, {f, t}, {j, k, l}, {m, n}, {l, m}, {t, 
           k}, {k, h, i}}])],2] 
       //. {q___, s : {a___, b_} | {___, {a___,  b_}, ___}, r___, 
       k : {b_, d___}, t__} -> {q, {s, k}, r, t})]]

{{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, t}, {t, k}, {k, h, i}}, {{l, m}, {m, n}}, {j, k, l}}

Now it will work for any number of elements in subsets. It can be a good alternate to using graphs.

$\endgroup$

Your Answer

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

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