How to generate all possible orderless partitions of a list according to another list?

Question

This question is hard to describe in plain text. So I will post an example and a working code (brute force) to illustrate.

For example I have a list: {1, 2, 3, 4, 5} and a partition list {2, 2, 1}. I will first choose 2 elements (there are 10 ways to do so), and then choose another 2 elements from the rest of the list (of length 3 and there are 3 ways to do so). The output is

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

The current working code is very memory-inefficient because it generates unnecessary lists first and deletes them later. Here it is:

f[list_, partition_] := 
 DeleteDuplicates[
  Sort /@ Internal`PartitionRagged[#, partition] & /@ 
   Permutations[list]]

I am also working on using Subsets to generate directly, but I have got lost in Folding with brackets, and the code is very long. Any elegant or efficient solutions would be appreciated.

Answer 1

A solution using Repeated, ReplaceList, and the Orderless attribute.

part[a_List, p_List] := 
  Module[{f, sym},
    Attributes[f] = Orderless;
    sym = Unique["x", Temporary] & /@ p;
    ReplaceList[
      f @@ a, 
      f @@ MapThread[Pattern[#, Repeated[_, {#2}]] &, {sym, p}] -> List /@ sym
    ]
  ]

part[{1, 2, 3, 4, 5}, {2, 2, 1}]

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

This proves to be an order of magnitude faster than BoLe's code:

SeedRandom[1]
p = RandomInteger[{1, 3}, 6];
a = Range @ Tr @ p;

Flatten[split[a, p]] /. sol -> List  // Length // RepeatedTiming

part[a, p]                           // Length // RepeatedTiming

{0.7517, 45360}

{0.0766, 45360}

---

Relation to Permutations

Note: I completely overlooked Simon Woods's answer before starting on this section. Nevertheless after reading and digesting his answer I believe I have something unique to offer.

I was reminded of a different approach to this problem using Permutations thanks to an apparently coincidental vote on an old answer of mine:

• How can I get every distinct size-n combination of a list?

Consider that there is a one-to-one mapping between your target list and this:

Permutations[{1, 1, 2, 2, 3}]

{{1, 1, 2, 2, 3}, {1, 1, 2, 3, 2}, . . ., {3, 2, 1, 2, 1}, {3, 2, 2, 1, 1}}

Permutations by itself is very efficient. It is nearly two orders of magnitude better than part defined above, and its output takes a fraction of the memory:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

a = Range @ 12;
p = {2, 3, 1, 3, 2, 1};

part[a, p] // ByteCount // RepeatedTiming
maskFn[p]  // ByteCount // RepeatedTiming

{6.49, 2075673680}

{0.0984, 319334552}

If you can write whatever operations follow this in terms of the permutation masks rather than the partitions there is clearly the potential for a major optimization.

Now, after reading Simon's answer and being inspired by it, I offer the following solution.

We can use Ordering as Simon did to convert the permutations, and then split the result using a slight modification of my dynP from:

• Partitioning with varying partition size

This provides my second proposal:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

dynP2[m_, p_] := 
 MapThread[
   m[[All, # ;; #2]] &,
   {{0} ~Join~ Most@# + 1, #} & @ Accumulate @ p
 ]\[Transpose]

part2[a_List, p_List] := dynP2[a[[ Ordering @ # ]] & /@ maskFn[p], p]

Comparing (in v10.1) the performance of both of my functions to Simon's parts:

a = Alphabet[] ~Take~ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.452, 831600}, {2.052, 831600}, {2.30, 831600}}

And again but with a packable a list:

a = Range @ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.45, 831600}, {1.59, 831600}, {1.43, 831600}}

It seems to me that part is still the best general function, but Simon's code is slightly faster in the case of a packed/packable input list.

Answer 2

Permutations treats repeated elements as identical, so you can get a flattened version of the desired result with something like

Ordering /@ Permutations[{1, 1, 2, 2, 3}]

(* {{1, 2, 3, 4, 5}, {1, 2, 3, 5, 4}, {1, 2, 4, 5, 3} ... {4, 5, 2, 3, 1} *)

A simple solution based on this idea:

parts[list_, p_] := Module[{q},
  q = Flatten@MapThread[ConstantArray, {Range@Length@p, p}];
  Internal`PartitionRagged[list[[Ordering[#]]], p] & /@ Permutations[q]]

Unforunately Internal`PartitionRagged is rather slow; it is faster (though less elegant) to create a function which does the reshaping:

parts[list_, p_] := Module[{q, f, slot},
  q = Flatten@MapThread[ConstantArray, {Range@Length@p, p}];
  f = Function @@ {Internal`PartitionRagged[Array[slot, Length@list], p]} /. slot -> Slot;
  f @@@ (list[[Ordering[#]]] & /@ Permutations[q])]

This is comparable to Mr Wizard's in terms of speed.

Answer 3

It's far from pretty, using pattern matching (OrderlessPatternSequence):

ReplaceList[#1,
  Module[{names = Unique[] & /@ #1, partitions},
    partitions = Internal`PartitionRagged[names, #2]; 
    Activate[{OrderlessPatternSequence @@ (Pattern[#, _] & /@ names)} /; 
       Evaluate[And @@ (Inactive@OrderedQ /@ partitions)] :> 
      Evaluate@partitions]]] &[Range@5, {2, 2, 1}]

The pattern we construct for the case of these arguments is:

{OrderlessPatternSequence[$3_, $4_, $5_, $6_, $7_]} /; 
 OrderedQ[{$3, $4}] && OrderedQ[{$5, $6}] && OrderedQ[{$7}] :> 
 {{$3, $4}, {$5, $6}, {$7}}

Answer 4

split1[s_List, p_List] :=
 (Fold[#1 /. temp[b___List] :> Map[
         temp[b, #] &, Subsets[Complement[s, b], {#2}]] &,
     temp[], p] // Flatten) /. temp -> List

---

Edit: I cleaned the code slightly, as the temporary head is unnecessary.

split2[s_List, p_List] :=
 Fold[#1 /. {x : {__Integer} ..} :> Sequence @@ Map[
       {x, #} &, Subsets[Complement[s, x], {#2}]] &,
  List /@ Subsets[s, {First@p}], Rest@p]

The code is always an order of magnitude slower than the fastest, yet it seems to share the computational complexity with them.

problem[n_] := {Range@Total@#, #} &@RandomInteger[{1, 3}, n]

timing[n_, methods__] := Module[{pr},
  pr = problem[n];
  Table[{n, RepeatedTiming[m @@ pr;][[1]]}, {m, {methods}}]]

data = Table[timing[n, split1, split2, parts], {n, 6}];

ListLogPlot[Transpose[data],
 Joined -> True,
 Mesh -> All,
 PlotRange -> All,
 PlotLegends -> {"BoLe 1", "BoLe 2", "Simon Woods"}]

Answer 5

g[l_, {n1_, n2_}] := (sb = Subsets[l, {n1}];
  Flatten[
   Table[{i1 = sb[[i]], i2 = Subsets[Complement[l, i1], {n2}][[j]], 
     Complement[l, {i1, i2}]}, {j, Length[l] - n1 - 1}, {i, 
     Length[sb]}], 1])
AbsoluteTiming[g[l, {2, 2}]]

0.000256

AbsoluteTiming[f[l, {2, 2, 1}]]

0.002062

Answer 6

FoldPairList, introduced in version 10.2 (but still [[EXPERIMENTAL]]), combined with the use of Ordering and Permutations, does what you want:

FoldPairList[TakeDrop, #, {2, 2, 1}] & /@ (Ordering /@ Permutations[{1, 1, 2, 2, 3}])