20
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ Related: (3044), (8528), (19672). Somewhat less related: (5036) $\endgroup$ – Mr.Wizard Aug 13 '16 at 15:01
  • $\begingroup$ Is it intentional that the desired result contains both {{1, 2}, {3, 4}, {5}} and {{3, 4}, {1, 2}, {5}}? They differ only in order, albeit at a higher level than the raw elements. $\endgroup$ – WReach Aug 13 '16 at 15:32
  • $\begingroup$ @WReach yes, the groups are distinct. $\endgroup$ – happy fish Aug 13 '16 at 15:55
15
$\begingroup$

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:

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:

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.

$\endgroup$
15
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ Nuts! Why do I always see these answers after I update my posts? $\endgroup$ – Mr.Wizard Aug 14 '16 at 20:18
12
$\begingroup$

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}}
$\endgroup$
12
$\begingroup$
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"}]

enter image description here

$\endgroup$
  • $\begingroup$ Now I feel like an idiot for not using Complement[], which would have made a generic version of my answer so much simpler. $\endgroup$ – Feyre Aug 13 '16 at 14:59
7
$\begingroup$
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

$\endgroup$
  • $\begingroup$ thanks, but actually the partition list is not limited to length 2 $\endgroup$ – happy fish Aug 13 '16 at 12:09
  • $\begingroup$ @happyfish This code works for any partition of 3, for example try AbsoluteTiming[g[Range[9], {4, 3}]] for {4,3,2} $\endgroup$ – Feyre Aug 13 '16 at 12:16
  • $\begingroup$ yes, I meant, partitions like {2, 3, 3, 3} $\endgroup$ – happy fish Aug 13 '16 at 12:17
  • $\begingroup$ @happyfish I see, well kirma 's already works for any kind, so rather than me expanding mine, you can accept his ;) $\endgroup$ – Feyre Aug 13 '16 at 12:20
3
$\begingroup$

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

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.