Join and Union nested lists if they intersect

Question

I'm a beginner for programming with Mathematica and have a simple question.

Suppose we have a list of lists, for example,

alist = {{1,3}, {2,3}, {4}}

I want to gather the lists if they have a common element. For example,

{{1,2,3}, {4}}

Another nontrivial example would be

blist = {{1}, {1,4}, {2,3}, {5,6}, {2,4}}
(*{{1,2,3,4}, {5,6}}*)

Length of each list is less than 2. Thanks.

Answer 1

It would probably be good to have a few more test cases, but this works for the two you provided. I'll build up to a final solution step-by-step. First off, there is a function called IntersectingQ that will tell you if two lists intersect. We can use this to gather intersecting lists together:

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

This adds a level to the data, so let's flatten it and de-dupe each list:

Union @@@ Gather[blist, IntersectingQ]
(* {{1, 4}, {2, 3, 4}, {5, 6}} *)

Hmm, since it only does one pass, we did not get the expected result. This suggests nesting this repeatedly. How many times? Until we get no further merges, i.e. the result no longer changes. That's a job for FixedPoint. But it would be nicer if we created a helper function first:

GatherStep[lists : {___List}] := Union @@@ Gather[lists, IntersectingQ]

And now we can apply FixedPoint:

FixedPoint[GatherStep, blist]
(* {{1, 2, 3, 4}, {5, 6}} *)

Answer 2

I thought of treating each sublist as a connected set of nodes, i.e. a graph. Then the problem is equivalent to finding which nodes are connected when we join all graphs together. So here is my solution:

gather[lists_] := Sort /@ ConnectedComponents[Graph[Union @@ lists, 
                    Union @@ (UndirectedEdge @@@ Partition[#, 2, 1] & /@ lists)]]

Explanation:

• Union @@ lists merges all the sublists to create the list of graph nodes. This is needed so that single nodes (like {4} in the example) don't get skipped.
• UndirectedEdge @@@ Partition[#, 2, 1] & is a function that creates a list of edges that connect a set of nodes, e.g. for the list {a, b, c} it creates the edges {a <-> b, b <-> c}.
• Union @@ (... /@ lists) applies the above function to every sublist and joins the results together.
• ConnectedComponents[Graph[..., ...]] creates a graph from the node and edge lists, and finds the sets of nodes that are connected to each other.
• Finally, Sort /@ ... is just to make the output match the examples, because ConnectedComponents can return the components in any order.

Answer 3

a = {{1, 3}, {2, 3}, {4}};
b = {{1}, {1, 4}, {2, 3}, {5, 6}, {2, 4}};
c = {{1}, {1, 4}, {2, 3}, {5, 6}, {2, 4}, {9, 8}};
d = {{1, 3}, {2, 3, 8}, {4}};

merge[a_] :=
 {DeleteDuplicates @ Flatten @ Pick[a, #], Splice @ Pick[a, #, False]} & [
  IntersectingQ @@@ Normal @ 
    GroupBy[
     DeleteCases[Tuples[a, {2}], {x_, x_}],
     First -> Last,
     Flatten]]

merge /@ {a, b, c, d} // Column

Answer 4

a = {{1, 3}, {2, 3}, {4}};
b = {{1}, {1, 4}, {2, 3}, {5, 6}, {2, 4}};
c = {{1}, {1, 4}, {2, 3}, {5, 6}, {2, 4}, {9, 8}};
d = {{1, 3}, {2, 3, 8}, {4}};

---

A variant of @eldo's answer using GroupBy:

 merge[a_] := Module[{gby, gbyt, gbyf},
  gby = GroupBy[Subsets[a, {2}], IntersectingQ[#[[1]], #[[2]]] &];
  gbyt = Union @@ Catenate@gby[True];
  gbyf = DeleteDuplicates@Pick[#, Nor@SubsetQ[gbyt, #] & /@ #] &@ 
         Catenate@gby[False];
  {gbyt, Splice@gbyf}]

merge /@ {a, b, c, d} // Column

Answer 5

A variant of @2012campion using RelationGraph:

func[u_] := 
 Union @@@ (VertexList /@ 
    ConnectedGraphComponents[
     RelationGraph[#1 != #2 && IntersectingQ[#1, #2] &, u]])

Testing:

alist = {{1, 3}, {2, 3}, {4}}
func[alist]

yields: {{1, 2, 3}, {4}}

test = {{1}, {1, 4}, {2, 3}, {5, 6}, {2, 4}};
func[test]

yields: {{1, 2, 3, 4}, {5, 6}}