Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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?

share|improve this question
    
why Block rather than Module? –  Mike Honeychurch Jan 30 '12 at 3:37
    
@Mike, no good reason; it could just as well be Module[] in there... –  J. M. Jan 30 '12 at 3:40
    
What is your application for this? –  Mike Honeychurch Jan 31 '12 at 3:36
    
@Mike: I'm using this to build lattices. The idea is to generate a series of points by rows, and then take the appropriate amount of points from two consecutive rows to build a tile. –  J. M. Jan 31 '12 at 3:58
    
Could tell me what the argument scts mean? Namely, which word's abbreviation is scts? –  Tangshutao Sep 24 at 6:26

6 Answers 6

up vote 11 down vote accepted

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.

share|improve this answer
    
multisegment[Range[10], {5, 4}, {2, 3}] almost gives the right answer... –  J. M. Jan 30 '12 at 4:17
    
that broke because Take was trying to take a position beyond the length of the list. Now fixed. –  Mike Honeychurch Jan 30 '12 at 4:30
    
You new code does not generate the entire set of partitions. Try the example multisegment[Range[100], {5, 4}, {2, 3}] –  Simon Jan 30 '12 at 10:12
    
fixed. just needed to modify the pad right length. –  Mike Honeychurch Jan 30 '12 at 11:08
1  
Nice generalization! :) –  J. M. Jan 31 '12 at 1:48

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
share|improve this answer
    
Maybe someone could test the "fastest" way to apply the conditions: partition list and offset list must be one or more positive integers. –  Mike Honeychurch Jan 31 '12 at 3:15

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~ {___,}
  ]
share|improve this answer
    
Dear Mr.Wizard, In blocks = Partition[l, Max @ Last @ ranges, +os], I cannot understand the +os, I execute it and give the result 4 (Assuming that the dpCyclic[Range@14, {4,3}, {3,1}]) –  Tangshutao Sep 15 at 8:23
    
@Tangshutao That's some of my devious shorthand. :o) It evaluates as Plus[os]. Please see: (31797), then also these other examples: (5038), (27554), (30240), (52318), (56670) –  Mr.Wizard Sep 15 at 8:36
    
OK, thanks sincerely :-) –  Tangshutao Sep 15 at 9:23

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"}}
*)
share|improve this answer
    
irregPartition[list, sizes, offsets] ==> {{1, 2, 3, 4, 5}, {3, 4, 5, 6}} not the result {{1,2,3,4,5},{3,4,5,6},{6,7,8,9,10}} that your answer gives. In addition, list = CharacterRange["a", "x"]; sizes = {4, 5, 3, 4}; offsets = {2, 7, 3, 5}; irregPartition[list, sizes, offsets] cannot achieve the result that you give –  Tangshutao Sep 14 at 8:09
    
@Tangshutao, right. I think this was posted two versions ago; need to check what has changed since version 8:) –  kguler Sep 14 at 14:53
    
Ok,thanks sincerely.:-) –  Tangshutao Sep 15 at 2:22

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"}}
share|improve this answer

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
share|improve this answer
    
Seems to fail if the partition list is not the same length as the offset list. e.g. multisegment[Range[24], {2, 4}, {3, 2, 4}] or multisegment[Range[24], {3, 2, 4}, {2, 4}] –  Mike Honeychurch Jan 31 '12 at 2:13
    
plus this multisegment[Range[24], {3, 2, 4}, {3, 2, 4}] returns an answer but it is incomplete. –  Mike Honeychurch Jan 31 '12 at 2:17
    
@Mike, Re: the first, I didn't set out to go for the case of the partition list and offset list not having the same length (hence the Length[p] == Length[os] condition). I have already upvoted your answer even before your generalization, though. Re: the second, it's an incommensurate case that I had not accounted for and is thus a bug; I'll think of a fix. –  J. M. Jan 31 '12 at 2:48
    
I've gone with polishing your version, Mike. :) –  J. M. Jan 31 '12 at 3:19
1  
Getting rid of Inner seems to speed it up. I am going to add that to mine :). Not noticing any speed improvement using TakeWhile instead of DeleteCases ...in fact that seems to slow it down a bit. And given that DeleteCases is a bit easier to read I will stick with that. –  Mike Honeychurch Jan 31 '12 at 3:32

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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