7
$\begingroup$

I have a large list and for simplicity, let's take the simple list as an example:

lists = {{1, 2}, {1, 6}, {2, 3}, {2, 5}, {3, 4}, {3, 6}, {4, 5}, {5, 6}}

I would like to partition the lists such that no repeated elements in every subsets, as the following result:

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

There are many nice answers about partition a list, see link1, link2. I have tried to modify their methods but I didn't wrok out as I want. Any advise to solve it? Thank you very much!

$\endgroup$
8
$\begingroup$
lists = {{1, 2}, {1, 6}, {2, 3}, {2, 5}, {3, 4}, {3, 6}, {4, 5}, {5, 6}};

Select[DuplicateFreeQ@*Catenate]@Subsets@lists
(* {{}, {{1, 2}}, {{1, 6}}, {{2, 3}}, {{2, 5}}, {{3, 4}}, {{3, 6}}, {{4, 5}}, {{5, 6}}, {{1, 2}, {3, 4}}, {{1, 2}, {3, 6}}, {{1, 2}, {4, 5}}, {{1, 2}, {5, 6}}, {{1, 6}, {2, 3}}, {{1, 6}, {2, 5}}, {{1, 6}, {3, 4}}, {{1, 6}, {4, 5}}, {{2, 3}, {4, 5}}, {{2, 3}, {5, 6}}, {{2, 5}, {3, 4}}, {{2, 5}, {3, 6}}, {{3, 4}, {5, 6}}, {{3, 6}, {4, 5}}, {{1, 2}, {3, 4}, {5, 6}}, {{1, 2}, {3, 6}, {4, 5}}, {{1, 6}, {2, 3}, {4, 5}}, {{1, 6}, {2, 5}, {3, 4}}} *)

Essentially, this generates all possible subsets, and then keeps only those that do not have duplicates in them (after merging the sublists). Note that also "non-maximal" subsets are generated, since those also fulfil your requirements. If you don't want them, you can tell Subsets to only generate subsets of length 3.

Of course, this is not super efficient, so if you have huge lists, you might need something that doesn't need to generate all subsets in advance.

$\endgroup$
1
  • $\begingroup$ that's a really nice solution and it helps a lot! Thank you very much! $\endgroup$
    – Xuemei
    Jul 12 at 16:51
9
$\begingroup$

TL;DR

We can think of each set as a vertex in a graph and the edges as showing whether or not the sets are disjoint, then finding all the maximum cliques.

lists = {{1, 2}, {1, 6}, {2, 3}, {2, 5}, {3, 4}, {3, 6}, {4, 5}, {5, 6}};
maximumDisjointSubcollections[collection_] := With[
  {graph = UndirectedEdge @@@ Select[Subsets[collection, {2}], Apply@DisjointQ] // Graph},
  FindClique[graph, {Length@First@FindClique@graph}, All]
]
maximumDisjointSubcollections@lists

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

Explanation

We can rethink of this as wanting "all subcollections of disjoint sets". This way, we can view the problem through the lens of Graph Theory by considering each set as a vertex and whether or not a pair of sets is disjoint (or not disjoint, depending on the solution) as an edge between their associated vertices.

We start by creating the graphs focusing on "disjoint-ness" and "intersecting-ness"

{djgraph, intgraph} = Graph[UndirectedEdge @@@ Select[Subsets[lists, {2}], Apply@#]] & /@ {DisjointQ, IntersectingQ}

enter image description here

Finding collections of disjoint sets with FindClique

The straightforward approach is associating edges with being disjoint. Now, we can translate our goal in terms of sets

Find all subcollections of sets such that each set is disjoint with every other set

to a goal in terms of vertices and edges

Find all sets of vertices such that each vertex has an edge to every other vertex

Or in other words

Find all subsets of vertices such that the corresponding induced subgraph is a complete graph.

This is an already established concept in Graph Theory and is known as each subset being a "clique". Thankfully, Mathematica has the native function FindClique to make our job easier. Though, we have a final question to ask ourselves; do we want only the largest subcollections (i.e. the maximum cliques) or all of them (i.e. the maximal cliques).

According to the given goal, we want only the largest subcollections. We can do that with

maximumDisjointSubcollections[collection_] := Block[
  {
    vertexPairs = Subsets[collection, {2}],
    disjointPairs,
    graph,
    cliqueNumber
  },
  disjointPairs = Select[vertexPairs, Apply@DisjointQ];
  graph = UndirectedEdge @@@ disjointPairs // Graph;
  cliqueNumber = Length@First@FindClique@graph;
  FindClique[graph, {cliqueNumber}, All]
]
maximumDisjointSubcollections@lists
(*Note: output was sorted to match given goal for comparison purposes*)

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

Avoiding intersections with FindIndependentVertexSet

It's also the case that (from the Background section of the FindClique documentation)

A maximal independent vertex set (which can be found using FindIndependentVertexSet) of a graph is equivalent to a maximal clique on its GraphComplement.

This is when we can reapproach the problem in considering intersecting sets. This amounts to effectively negating DisjointQ and FindClique in the underlying algorithm of the above function to IntersectingQ and FindIndependentVertexSet, respectively to yield

(*Make a graph whose edges dictate a non-empty intersection*)
UndirectedEdge @@@ Select[Subsets[lists, {2}], Apply@IntersectingQ] // Graph
(*Find a maximal set of vertices that are never incident to the same edge.*)
FindIndependentVertexSet[%, {3, Infinity}, All]

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

P.S.

While I started trying to use Graph Theory on my own but met a dead end in trying to find a way to use DepthFirstScan with directed graphs and some sort of tree structure, I have to shoutout Carl Woll and their very similar answer here to a very similar question for providing the inspiration for much simpler and clever way of going about the problem.

$\endgroup$
1
  • 2
    $\begingroup$ that's a very good example which connecting to graph theory! and thank you very much that let me know the in-builted function FindIndependentVertexSet and related FindIndependentEdgeSet. $\endgroup$
    – Xuemei
    Jul 13 at 5:40
7
$\begingroup$

Here's an approach that I believe is equivalent to NonDairyNeutrino's answer, but repackaged to use SatisfiabilityInstances instead:

listPartitions[l_, len_] := Module[{z = Table[Unique["z"], Length[l]], intersecting, instances},
    intersecting = Pick[Subsets[z,{2}], IntersectingQ@@@Subsets[l, {2}]];
    instances = SatisfiabilityInstances[
        BooleanCountingFunction[{len}, z] &&
        BooleanCountingFunction[1, 2] @@@ And @@ intersecting,
        z,
        All
    ];
    Pick[l, #]& /@ instances
]

Your example:

listPartitions[lists, 3]

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

$\endgroup$
1
  • $\begingroup$ wo, nice solution! thank you! $\endgroup$
    – Xuemei
    Jul 13 at 5:33

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.