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

Improve this question
$\endgroup$
3
  • $\begingroup$ Related: (3044), (8528), (19672). Somewhat less related: (5036) $\endgroup$ Commented Aug 13, 2016 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$ Commented Aug 13, 2016 at 15:32
  • $\begingroup$ @WReach yes, the groups are distinct. $\endgroup$ Commented Aug 13, 2016 at 15:55

6 Answers 6

Reset to default
17
$\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.

Improve this answer
$\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.

Improve this answer
$\endgroup$
1
  • $\begingroup$ Nuts! Why do I always see these answers after I update my posts? $\endgroup$ Commented Aug 14, 2016 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}}
Improve this answer
$\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

Improve this answer
$\endgroup$
1
  • $\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$ Commented Aug 13, 2016 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

Improve this answer
$\endgroup$
4
  • $\begingroup$ thanks, but actually the partition list is not limited to length 2 $\endgroup$ Commented Aug 13, 2016 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$ Commented Aug 13, 2016 at 12:16
  • $\begingroup$ yes, I meant, partitions like {2, 3, 3, 3} $\endgroup$ Commented Aug 13, 2016 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$ Commented Aug 13, 2016 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}])
Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.