42
$\begingroup$

Given a set $\{a_1,a_2,\dots,a_{lk}\}$ and a positive integer $l$, how can I find all the partitions which includes subsets of size $l$ in Mathematica? For instance, given {1,2,3,4} and l=2, the output should be:

$$\text{Partition 1: }\{1,2\},\{3,4\}$$ $$\text{Partition 2: }\{1,3\},\{2,4\}$$ $$\text{Partition 3: }\{1,4\},\{2,3\}$$

In Mathematica notation:

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

Edit: Another example for l=3, and {1,2,3,4,5,6}:

{
 {{1, 2, 3}, {4, 5, 6}}, 
 {{1, 2, 4}, {3, 5, 6}}, 
 {{1, 2, 5}, {3, 4, 6}}, 
 {{1, 2, 6}, {3, 4, 5}},
 {{1, 3, 4}, {2, 5, 6}},
 {{1, 3, 5}, {2, 4, 6}}, 
 {{1, 3, 6}, {2, 4, 5}},
 {{1, 4, 5}, {2, 3, 6}},
 {{1, 4, 6}, {2, 3, 5}},
 {{1, 5, 6}, {2, 3, 4}}
}
Improve this question
$\endgroup$
4
  • $\begingroup$ @murray: I think it would be clear if you read the example. The size of the set is $kl$, so it can be simply partitioned into $k$ subsets of size $l$. I am looking for all such partitions. $\endgroup$
    – Helium
    Mar 15, 2012 at 23:57
  • $\begingroup$ @Mohsen, yes, I know you use $k$ and $l$ but unfortunately in your example, $k$ = $l$ = 2. Which is why it's hardly the best example one might start from. $\endgroup$
    – murray
    Mar 16, 2012 at 3:35
  • $\begingroup$ @murray: I just added a new example with $k=2$ and $l=3$. $\endgroup$
    – Helium
    Mar 16, 2012 at 17:57
  • $\begingroup$ Somewhat related (note to self): (5036) $\endgroup$
    – Mr.Wizard
    Sep 15, 2014 at 8:44

6 Answers 6

Reset to default
39
$\begingroup$

Try with

partitions[list_, l_] := Join @@
  Table[
    {x, ##} & @@@ partitions[list ~Complement~ x, l],
    {x, Subsets[list, {l}, Binomial[Length[list] - 1, l - 1]]}
  ]

partitions[list_, l_] /; Length[list] === l := {{list}}

The list must have a length multiple of l

Improve this answer
$\endgroup$
5
  • 1
    $\begingroup$ Could someone explain this awesome but mysterious function? $\endgroup$
    – AndyS
    Feb 13, 2014 at 20:59
  • 2
    $\begingroup$ @AndyS Start here, where Rojo explained his algorithm to me: chat.stackexchange.com/transcript/message/3837894#3837894 Later I refactored the code, hopefully for the better. If the difficulty lies in the syntax rather than the algorithm let me know and I'll explain it. $\endgroup$
    – Mr.Wizard
    Mar 17, 2014 at 16:21
  • $\begingroup$ @Mr.Wizard Would you be able to come up with an incremental version of this. I need the partitions lexicographically sorted one at a time, so that I can generate one, process, and move on to the next one. This way I can check many more than fit in my laptop. I could even stop and restart. This is terrific code, so I wonder if something like it can be done for the problem I am asking about ... or should I start a post? I am not sure I would know how to write it code like this for what I want. I could work with in lists of say 20 elements as opposed to 16 ... very significant in my world. $\endgroup$
    – EGME
    Nov 20, 2019 at 23:09
  • $\begingroup$ @EGME I suggest you start a new Quesiton. This is Rojo's code, and unfortunately it appears he doesn't post here any more. Nevertheless I'll try my hand at it tomorrow, but you'll probably have an answer by then. You may find it best to work in blocks of partitions rather than one partition at a time, as the latter is typically quite slow in top-level Mathematica code. $\endgroup$
    – Mr.Wizard
    Nov 21, 2019 at 3:48
  • 1
    $\begingroup$ @Mr.Wizard I posted mathematica.stackexchange.com/q/210033/53849 $\endgroup$
    – EGME
    Nov 21, 2019 at 19:47
16
$\begingroup$

I believe this is correct. It is based on BellList from Robert M. Dickau.

Module[{n = 4, q = 2, r, BellList},
 r = n/q;
 BellList[1] = {{{1}}};
 BellList[n_Integer?Positive] :=
  Join @@ (ReplaceList[#,
         {{b___, {S : Repeated[_, {1, q - 1}]}, a___} :> {b, {S, n}, a},
         {S : Repeated[_, {1, r - 1}]} :> {S, {n}}}
        ] & /@ BellList[n - 1]);
 BellList[n]
]

You'll have to make sure n is divisible by q or adapt it to behave as you want. Also, this uses natural numbers for the set, but these in turn can be used as indices to extract elements from the working set.

Improve this answer
$\endgroup$
1
  • $\begingroup$ +1 for throwing in the formal name of the problem. I had a hard time googling it. $\endgroup$
    – István Zachar
    Mar 15, 2012 at 20:06
5
$\begingroup$

Use Subsets:

Subsets[{1, 2, 3, 4}, {2}]

Gives:

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

Edit How about:

a = {1, 2, 3, 4};
DeleteDuplicates[Sort /@ (Sort /@ Partition[#, 2] & /@ Permutations[a, {4}])]

which outputs

 {{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}
Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ Actually, I am looking for partitions, not permutations. So, $\{1,2\},\{3,4\}$ is one partition and $\{1,3\},\{2,4\}$ is another one. I just edited the question to clarify this. $\endgroup$
    – Helium
    Mar 15, 2012 at 19:12
  • $\begingroup$ How's this version? $\endgroup$
    – Eli Lansey
    Mar 15, 2012 at 19:40
3
$\begingroup$

Really lazy search through all partitioned permutations:

set = {1, 2, 3, 4};
Union[Sort /@ (Sort /@ Partition[#, 2] & /@ 
     Permutations[set, {4}])]

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

And a more economic one:

set = {1, 2, 3, 4};
subsets = Subsets[set, {2}];
Table[{i, Cases[subsets, _?(Union[#, i] === set &)]}, {i, 
   Take[subsets, Length@subsets/2]}]

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

This generates all the subsets of size 2 (6 of them), and scans through them one-by-one to find their complement in the same list. Since it can be assumed that the output of Subsets is regular, the above can be simplified to simply split the subsets list to two, and merging the first half with the reversed second half.:

n = Length@subsets;
MapThread[List, {Take[subsets, n/2], Take[Reverse@subsets, n/2]}]
Improve this answer
$\endgroup$
2
  • $\begingroup$ Thanks István, actually I am looking for a solution for a general $l$, not only $l=2$. So, your last solution doesn't help, but the other ones looks great. I tested them for $l=3$ and $k=3$ (i.e., 9 numbers) and they work perfect, but for 12 numbers they don't. Is there any way to solve the issue or there are too many partitions with $l=3$ and $k=4$, ummm? $\endgroup$
    – Helium
    Mar 15, 2012 at 19:48
  • $\begingroup$ Yes, I have realized that, so I am now working on a general solution. For the worst, one can do a partial tree-traversal by fixing the first digit and changing the next one, fixing it and changing the next one, etc... I'm pretty sure that before I could solve this, others will post some beautiful answers. $\endgroup$
    – István Zachar
    Mar 15, 2012 at 19:59
2
$\begingroup$

You might start with the Combinatorica add-on function SetPartitions and then select those partitions satisfying the condition about the size of their members. But this may be too "extravagant" an approach when the original set size becomes a bit big.

Improve this answer
$\endgroup$
1
$\begingroup$ 
subsetsPartition[list_, n_] := 
 Select[Subsets[Subsets[list, {n}], {Length[list]/n}], DuplicateFreeQ@*Catenate]

subsetsPartition[Range[4], 2]
subsetsPartition[Range[6], 2]

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

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

Improve this answer
$\endgroup$

Your Answer

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

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