6
$\begingroup$

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.

$\endgroup$
2
  • $\begingroup$ It might help searching for existing solutions if we note that you're asking for the equivalence classes of the equivalence relation generated by the given relation. $\endgroup$ Sep 22, 2022 at 16:15
  • $\begingroup$ Similar to 7620 and 116285, 11059 and perhaps many others. $\endgroup$
    – Syed
    Oct 10, 2022 at 19:30

5 Answers 5

10
$\begingroup$

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}} *)
$\endgroup$
7
$\begingroup$

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.
$\endgroup$
3
$\begingroup$
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

enter image description here

$\endgroup$
2
$\begingroup$
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

enter image description here

$\endgroup$
1
$\begingroup$

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}}

$\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.