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$
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$
  • $\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 '13 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 '13 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$ – Leonid Shifrin Nov 18 '13 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$ – Leonid Shifrin Nov 19 '13 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$
  • $\begingroup$ This one fails on list = RandomInteger[100, {100, 10}] due to multiple edges. $\endgroup$ – Szabolcs Nov 18 '13 at 19:03
  • $\begingroup$ @Szabolcs Good catch! One can add DeleteDuplicates but it is not very good. $\endgroup$ – ybeltukov Nov 18 '13 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$
  • $\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$ – Leonid Shifrin Nov 19 '13 at 11:14
  • $\begingroup$ Thanks. I found your code here. $\endgroup$ – Ray Koopman Nov 19 '13 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$ – Leonid Shifrin Nov 19 '13 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$
  • $\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 '13 at 18:44
2
$\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, privacy policy and cookie policy

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