On generalizing Partition[] (with offsets) to sublists of unequal length

Question

The usual Partition[] function is a very handy little thing:

Partition[Range[12], 4]
{{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}}

Partition[Range[13], 4, 3]
{{1, 2, 3, 4}, {4, 5, 6, 7}, {7, 8, 9, 10}, {10, 11, 12, 13}}

One application I'm working on required me to write a particular generalization of Partition[]'s functionality, which allowed the generation of sublists of unequal lengths, for as long as the lengths were appropriately commensurate. (Let's assume for the purposes of this question that the list lengths being commensurate is guaranteed, but you're welcome to generalize further to the incommensurate case.) Here's my generalization in action:

multisegment[lst_List, scts_List] := Block[{acc},
  acc = Prepend[Accumulate[PadRight[scts, Length[lst]/Mean[scts], scts]], 0];
  Inner[Take[lst, {#1, #2}] &, Most[acc] + 1, Rest[acc], List]]

multisegment[CharacterRange["a", "x"], {3, 1, 2}]
{{"a", "b", "c"}, {"d"}, {"e", "f"}, {"g", "h", "i"}, {"j"}, {"k", "l"},
 {"m", "n", "o"}, {"p"}, {"q", "r"}, {"s", "t", "u"}, {"v"}, {"w", "x"}}

(Thanks to halirutan for optimization help with multisegment[].)

The problem I've hit into is that I wanted multisegment[] to also support offsets, just like in Partition[]. I want to be able to do something like the following:

multisegment[Range[14], {4, 3}, {3, 1}]
{{1, 2, 3, 4}, {4, 5, 6}, {5, 6, 7, 8}, 
 {8, 9, 10}, {9, 10, 11, 12}, {12, 13, 14}}

How might a version of multisegment[] with offsets be accomplished?

Answer 1

This is a complete re-write

This is the original solution which was done in haste but i will leave here. It works in limited cases:

multisegment[lst_List, scts_List, offset_List] := 
 Module[{acc, offs}, 
  offs = 1+Prepend[Accumulate[PadRight[offset, 
      1 + Ceiling[Length[lst]/Total[offset]], offset]], 0];
  acc = PadRight[scts, Length[offs],scts];
  acc = acc + offs - 1;
  Inner[Take[lst, {#1, #2}] &, offs, acc, List]
  ]

multisegment[Range[14], {4, 3}, {3, 1}]
{{1, 2, 3, 4}, {4, 5, 6}, {5, 6, 7, 8}, {8, 9, 10}, {9, 10, 11, 
  12}, {12, 13, 14}}

To solve this you note that the starting position (for Part or Take) of the list depends solely on the offset list:

{1,4,5,8,9,12}

The "span to" position is determined by adding the partition list

{4,3,4,3,4,3}

to the offset list (minus 1) to give

{4,6,8,10,12,14}

From there, proceed as before with Inner and use either Take or Part. So this becomes an exercise in generating the correct offset list. As earlier failed attempts have shown, this is dependent on both the total of the offsets and the length of the offsets (list).

But also you do not want your Take or "span to" range exceeding the length of your target list. I have taken the easy way out here but using DeleteCases. A more exact and possibly elegant, but maybe not faster (?), approach is to actually work this out based on the partition list.

multisegment[lst_List, scts_List, offset_List] := 
 Module[{fin, offs, len = Length[lst], tot = Total[offset], len2 = Length[offset]}, 
  offs = 1 + Prepend[Accumulate[
      PadRight[offset, Ceiling[len2*len/tot], offset]], 0];
  fin = PadRight[scts, Length[offs], scts] + offs - 1;
  fin = DeleteCases[Transpose[{offs, fin}], {_, x_ /; x > len}];
  Take[lst, #] & /@ fin]

 (* case for no offsets *)
 multisegment[lst_List, scts_List] := multisegment[lst, scts, scts]

I prefer to layout the code in steps rather than combine multiple steps into a one (or two) liner. Feel free to do that if you wish but I think this way makes it easier for people to check out what is happening.

Also a qualifier: checks and/or conditions should be added. you cannot have {0} for your partition or offset. Must be integers etc. as per Simon's comments.

Usage. First the base case of an uneven partition with no offset

multisegment[Range[14], {3, 4}]
{{1, 2, 3}, {4, 5, 6, 7}, {8, 9, 10}, {11, 12, 13, 14}}

now add an offset

multisegment[Range[14], {3, 4}, {1, 2}]
{{1, 2, 3}, {2, 3, 4, 5}, {4, 5, 6}, {5, 6, 7, 8}, {7, 8, 9}, {8, 9, 
  10, 11}, {10, 11, 12}, {11, 12, 13, 14}}

Examples that previously failed:

multisegment[Range[10], {5, 4}, {2, 3}]
{{1, 2, 3, 4, 5}, {3, 4, 5, 6}, {6, 7, 8, 9, 10}}

multisegment[Range[100], {5, 4}, {2, 3}]
{{1, 2, 3, 4, 5}, {3, 4, 5, 6}, {6, 7, 8, 9, 10}, {8, 9, 10, 11}, {11,
   12, 13, 14, 15}, {13, 14, 15, 16}, {16, 17, 18, 19, 20}, {18, 19, 
  20, 21}, {21, 22, 23, 24, 25}, {23, 24, 25, 26}, {26, 27, 28, 29, 
  30}, {28, 29, 30, 31}, {31, 32, 33, 34, 35}, {33, 34, 35, 36}, {36, 
  37, 38, 39, 40}, {38, 39, 40, 41}, {41, 42, 43, 44, 45}, {43, 44, 
  45, 46}, {46, 47, 48, 49, 50}, {48, 49, 50, 51}, {51, 52, 53, 54, 
  55}, {53, 54, 55, 56}, {56, 57, 58, 59, 60}, {58, 59, 60, 61}, {61, 
  62, 63, 64, 65}, {63, 64, 65, 66}, {66, 67, 68, 69, 70}, {68, 69, 
  70, 71}, {71, 72, 73, 74, 75}, {73, 74, 75, 76}, {76, 77, 78, 79, 
  80}, {78, 79, 80, 81}, {81, 82, 83, 84, 85}, {83, 84, 85, 86}, {86, 
  87, 88, 89, 90}, {88, 89, 90, 91}, {91, 92, 93, 94, 95}, {93, 94, 
  95, 96}, {96, 97, 98, 99, 100}}

Example showing it working with increasing offset list length

multisegment[Range[44], {3, 4}, {1, 3, 2}]
{{1, 2, 3}, {2, 3, 4, 5}, {5, 6, 7}, {7, 8, 9, 10}, {8, 9, 10}, {11, 
  12, 13, 14}, {13, 14, 15}, {14, 15, 16, 17}, {17, 18, 19}, {19, 20, 
  21, 22}, {20, 21, 22}, {23, 24, 25, 26}, {25, 26, 27}, {26, 27, 28, 
  29}, {29, 30, 31}, {31, 32, 33, 34}, {32, 33, 34}, {35, 36, 37, 
  38}, {37, 38, 39}, {38, 39, 40, 41}, {41, 42, 43}}

multisegment[Range[44], {3, 4}, {1, 3, 2, 4}]
{{1, 2, 3}, {2, 3, 4, 5}, {5, 6, 7}, {7, 8, 9, 10}, {11, 12, 13}, {12,
   13, 14, 15}, {15, 16, 17}, {17, 18, 19, 20}, {21, 22, 23}, {22, 23,
   24, 25}, {25, 26, 27}, {27, 28, 29, 30}, {31, 32, 33}, {32, 33, 34,
   35}, {35, 36, 37}, {37, 38, 39, 40}, {41, 42, 43}}

and so on, and so forth.

Answer 2

Here's my version using the Sow and Reap combination.

multisegment::arglen = 
  "The argument `1` is not of the same length as the argument `2`.";

multisegment[lst_List, scts_List, offsets_List] := 
 Module[{len = Length[lst], slen = Length[scts], i = 1, j = 1}, 
   Reap[If[slen =!= Length[offsets],
     Message[multisegment::arglen, scts, offsets]; Sow[$Failed],
     Do[Sow[Take[lst, {i, i + scts[[j]] - 1}]];
      i = i + offsets[[j]]; j = Mod[j + 1, slen, 1];
      If[i + scts[[j]] - 1 > len, Break[]],
      {len/Total[offsets]*slen}]]]][[2, 1]]
multisegment[lst_List, scts_List] := multisegment[lst, scts, scts]

Note that you should also add checks to make sure that the scts and offsets arguments are all integers and that Total[offsets] > 0 etc...

---

Here's the relative timings (using my TimeAv code) for running

multisegment[Range[n], {4, 3}, {3, 1}]; // TimeAv

with various values of n and the different solutions presented so far. The timing of my version of multisegment is normalised to 1.

                Mike H    Heike    

n = 200        0.488689, 2.17595 

n = 20 000     0.444445, 4.00373

n = 200 000    0.495761, 54.6492

Answer 3

My first method was related to Mike's, yet unrefined. This is another method designed for speed. As written it only returns the portion of the list which can be partitioned into a complete set of partitions. This behavior can be changed with 4th+ argument of Partition and/or filtering.

dpCyclic[l_List, p : {__Integer?Positive}, {os__Integer?Positive}] :=
  Module[{ranges, blocks},
    ranges = {# + 1, # + p} & @ Most @ Accumulate @ {0, os};
    blocks = Partition[l, Max @ Last @ ranges, +os];
    MapThread[blocks[[All, # ;; #2]] &, ranges] ~Flatten~ {2, 1}
  ]

As an example of different behavior (with implicit Nulls):

dpCyclic[l_List, p : {__Integer?Positive}, {os__Integer?Positive}] :=
  Module[{ranges, blocks},
    ranges = {# + 1, # + p} & @ Most @ Accumulate @ {0, os};
    blocks = Partition[l, Max @ Last @ ranges, +os, 1,];
    MapThread[blocks[[All, # ;; #2]] &, ranges] ~Flatten~ {2, 1} ~DeleteCases~ {___,}
  ]

Answer 4

Also related to Mike's solution:

ClearAll[irregPartition];
irregPartition[list_List, sizes_List, offsets_List] := 
  Module[{offsetlist, sizelist},
   offsetlist = (NestWhile[Join[offsets, #] &,offsets, (Tr@# < Length@list) &] //
     NestWhile[Most, #, (Tr@# >= Length@list) &] & // Accumulate //
    Prepend[#, 0] & ) + 1;
 sizelist = NestWhile[Join[sizes, #] &,sizes,(Length@# <= Length@offsetlist) &] //
 NestWhile[Most, #, Length@# > Length@offsetlist &] &;
{offsetlist, sizelist} =Transpose@TakeWhile[
  Partition[Riffle[offsetlist, sizelist], 2], #[[1]] + #[[2]] <= Length@list &];
MapThread[Take[#1,Min[#2, Length@#1]] &, {Drop[list, 
     Min[#, Length@list]] & /@ (offsetlist - 1), sizelist}] // 
If[Length@Last@# < Last@sizelist, Most@#, #] &];

irregPartition[list_List, sizes_List] := irregPartition[list, sizes, sizes];

Example:

list = Range[10];
sizes = {5, 4};
offsets = {2, 3};
irregPartition[list, sizes, offsets]
(* 
==> {{1,2,3,4,5},{3,4,5,6},{6,7,8,9,10}}
*)
irregPartition[list, sizes]
(*
==> {{1,2,3,4,5},{6,7,8,9}
*)

Another example:

list = CharacterRange["a", "x"];
sizes = {4, 5, 3, 4};
offsets = {2, 7, 3, 5};
irregPartition[list, sizes, offsets]
(*
 ==> {{"a","b","c","d"},{"c","d","e","f","g"},{"j","k","l"},{"m","n","o","p"},{"r","s","t","u"},{"t","u","v","w","x"}}
*)
irregPartition[list, sizes]
(*
==> {{"a","b","c","d"},{"e","f","g","h","i"},{"j","k","l"},{"m","n","o","p"},{"q","r","s","t"}}
*)

Answer 5

Whit solution is using a NestWhile construction in combination with Sow and Reap

partitions[list_, {parts_List, offsets_List}] :=
  Reap[
    NestWhile[{RotateLeft[#[[1]]], RotateLeft[#[[2]]], 
      Sow[#[[3]][[;; #[[1, 1]]]]]; ArrayPad[#[[3]], {-#[[2, 1]], 0}]} &,
     {parts, offsets, list},
     (Length[#[[3]]] >= #[[1, 1]]) &];
  ][[2, 1]]

partitions[list_, p : {__?NumericQ}] := partitions[list, {p, p}]

Example

list = CharacterRange["a", "z"];

partitions[list, {{3, 4}, {1, 3}}]

 {{"a", "b", "c"}, {"b", "c", "d", "e"}, {"e", "f", "g"}, 
  {"f", "g", "h", "i"}, {"i", "j", "k"}, {"j", "k", "l", "m"}, 
  {"m", "n", "o"}, {"n", "o", "p", "q"}, {"q", "r", "s"}, 
  {"r", "s", "t", "u"}, {"u", "v", "w"}, {"v", "w", "x", "y"}}

Answer 6

I've managed to slightly build on Mike's answer. There's a minimum (i.e., woefully incomplete) amount of checking done, but it should mostly work:

multisegment[lst_List, scts:{__Integer?Positive}, offset:{__Integer?NonNegative}]:= 
 Module[{n = Length[lst], k, offs},
   k = Ceiling[n/Mean[offset]];
   offs = Prepend[Accumulate[PadRight[offset, k, offset]], 0];
   Take[lst, #] & /@ TakeWhile[
           Transpose[{offs + 1, offs + PadRight[scts, k + 1, scts]}], 
           Apply[And, Thread[# <= n]] &]] /; Length[scts] == Length[offset]

multisegment[lst_List, scts:{__Integer?Positive}] := 
 multisegment[lst, scts, scts] /; Mod[Length[lst], Total[scts]] == 0