Variable iterator in Do Loop (splitting a list)

Question

I have a list in Mathematica that looks like the following:

{{92,3},{23,3},{93,3},{63,2},{66,2},{24,4},{94,4},{27,4},{72,4},....}

The point is that the second number in each row dictates how many entries of that type there will be consecutively (3 consecutive "3" entries, 4 consecutive "4" entries, etc.)

My goal is to rearrange this list so that it looks like:

{{92,23,93},{63,66},{24,94,27,72},...}

so that I can plot the data with these numbers stacked on each other.

I am attempting to do this with the following module:

roundtrips[table_]:=Module[{newtable,numpeaks,i},
            Do[
              numpeaks=table[[i]][[2]];
              newtable[[i]]=Table[table[[i]],{i,i+numpeaks-1}],
              {i,1,Length[table], ???}]
               ]

What I would like to do is have the stepsize of the iterator vary based on what numpeaks is, so that it doesn't double or triple count entries. My first attempt was to put numpeaks in place of ???, but Mathematica didn't like this. Is there a good way to do this, or an easier way to do what I'm trying to do?

---

clarified in a comment:

So for example, I would want: {{34,2},{83,2},{24,2},{74,2}} to become {{34,83},{24,72}}

Answer 1

I believe this is a job for SplitBy with some post-processing:

separate[lst:{{_, _Integer} ..}] :=
  Flatten[Partition[#, #[[1, 2]]] & /@ SplitBy[lst, Last], 1][[All, All, 1]]

Alternatively (and a touch faster),

separate[lst : {{_, _Integer} ..}] :=
  (Sequence @@ Partition[#, #[[1, 2]]] & /@ SplitBy[lst, Last])[[All, All, 1]]

Here is an explanation of the process:

Take as a sample list

lst = {{a, 3}, {b, 3}, {c, 3}, {d, 2}, {e, 2}, {f, 2}, {g, 2}, {h, 4}, {i, 4}, {j, 4}, {k, 4}};

Then

lst2 = SplitBy[lst, Last]
(* {{{a, 3}, {b, 3}, {c, 3}}, {{d, 2}, {e, 2}, {f, 2}, {g, 2}}, {{h, 4}, {i, 4}, {j, 4}, {k, 4}}} *)

We can see that the elements labeled d, e, f, and g have been improperly grouped. So we do some post-processing of these lists by Partitioning the sets by the number:

lst3 = Partition[#, #[[1, 2]]] & /@ lst2
(* { {{{a, 3}, {b, 3}, {c, 3}}},
     {{{d, 2}, {e, 2}}, {{f, 2}, {g, 2}}},
     {{{h, 4}, {i, 4}, {j, 4}, {k, 4}}}} *)

It's still not quite right, so we Flatten once:

lst4 = Flatten[lst3, 1]
(* {{{a, 3}, {b, 3}, {c, 3}}, {{d, 2}, {e, 2}}, {{f, 2}, {g, 2}}, {{h, 4}, {i, 4}, {j, 4}, {k, 4}}} *)

Finally, take only the first elements:

lst4[[All, All, 1]]
(* {{a, b, c}, {d, e}, {f, g}, {h, i, j, k}} *)

Update 1

Here is another version that is about 8 times slower than my other one, but it's cute because it does the Splitting in one go:

separate2[lst : {{_, _Integer} ..}] := 
  Module[{i = 1}, SplitBy[lst, If[2 #[[2]] - 1 > i++, 1, i = 0; 0] &]][[All, All, 1]]

---

Some basic timings. We generate a sample list:

SeedRandom[1]
lst = Flatten[Table[{RandomInteger[{1, #}], #}, {#}] & /@ RandomInteger[{1, 7}, 3000], 1];
lst // Length
(* 11883 *)

and then

lst // separate; // AbsoluteTiming // First
lst // separate2; // AbsoluteTiming // First
(* 0.025516 *)
(* 0.083057 *)

Update 2

Here is a replacement-based approach using Sow and Reap that I feel is pretty clever, but it is really slow:

separate3[lst : {{_, _Integer} ..}] := 
  Last@Reap[
    lst //. {pat : Longest[PatternSequence[{_, n_Integer} ..]], b___}
      :> (Sow[Partition[{pat}[[All, 1]], n]]; {b})
   ]~Flatten~2

So don't try it on big lists! It scales terribly.

Update 3

Here's another solution, using recursion. It's much better than the replacement version, but still a lot significantly slower than the first two versions at large list sizes. Still, I like it:

Clear@func
func[{}] = {};
func[lst_List] := Module[{},
  Sow[Partition[lst[[;; #, 1]], #] &@lst[[1, 2]]];
  func[Drop[lst, lst[[1, 2]]]];
 ]
separate4[lst : {{_, _Integer} ..}] := 
  Block[{$RecursionLimit = 10000}, Last@Reap@func[lst]~Flatten~2]

Answer 2

Update: After further consideration here is a method that I believe is both elegant and closer in spirit to your own code. I am calling it fn0 as I probably should have started with this. Nevertheless I hope that you find the other methods I provide also of interest.

fn0[a_List] :=
  Module[{p = 1, n = Length @ a},
    Join @@ Table[a[[p++, 1]], {n}, {Boole[p < n]}, {a[[p + 1, 2]]}]
  ]

Using the same principle as Partitioning a list when the cumulative sum exceeds 1:

fn1[a_List] :=
  Module[{i = a[[1, 2]]},
    Split[a, --i > 0 || (i = #2[[2]]) &][[All, All, 1]]
  ]

Using a method similar to Partitioning with varying partition size:

fn2[a_List] :=
  Inner[a[[# ;; #2, 1]] &, #[[;; -2]] + 1, #[[2 ;;]], List] & @ 
    NestWhileList[# + a[[# + 1, 2]] &, 0, Evaluate[Length[a] > #] &]

And now using Compile for NestWhileList a la partitionBy3:

fnRLE =
  Compile[{{aa, _Integer, 1}},
    With[{n = Length[aa]},
      NestWhileList[# + aa[[# + 1]] &, 0, n > # &]
    ]
  ];

fn2fast[a_List] :=
  Module[{a1, a2},
    {a1, a2} = List @@ (a\[Transpose]);  (* /q/28998/ *)
    Inner[a1[[# ;; #2]] &, #[[;; -2]] + 1, #[[2 ;;]], List] & @ fnRLE @ a2
  ]

A different method also using dynamic/ragged partitioning:

fn3[a_List] :=
  Internal`PartitionRagged[
    a[[All, 1]],
    ConstantArray[#[[1]], Length[#]/#[[1]]] & /@ Split @ a[[All, 2]] // Catenate
  ]

Test:

test = {{92, 3}, {23, 3}, {93, 3}, {63, 2}, {66, 2}, {24, 4},
 {94, 4}, {27, 4}, {72, 4}, {34, 2}, {83, 2}, {24, 2}, {74, 2}};

fn0[test]

% === fn1[test] === fn2[test] === fn2fast[test] === fn3[test]

{{92, 23, 93}, {63, 66}, {24, 94, 27, 72}, {34, 83}, {24, 74}}

True

Benchmark

Here is a benchmark including march's methods. I did not test separate3 or separate4 as he notes these as being slower. I also omitted the argument testing from his functions to eliminate any overhead associated with it.

mkSample[m_Integer][n_Integer] := 
  Flatten[
    Table[{RandomInteger[{1, #}], #}, {#}] & /@ RandomInteger[{1, m}, n],
    1
  ] // Developer`ToPackedArray;

Needs["GeneralUtilities`"]

fns = {separate, separate2, fn0, fn1, fn2, fn2fast, fn3};

BenchmarkPlot[fns, mkSample[13], "IncludeFits" -> True]

I don't know why BenchmarkPlot fits fn2fast as $n*log(n)$ as all these functions appear to be linear time.

Answer 3

Perhaps this with some fake data generated to test it.

list=Join@@Table[{{RandomInteger[{1,20}],2},{RandomInteger[{1,20}],2}}, {2000}];
Reap[
  While[list != {},
    Sow[Map[First, Take[list, list[[1, 2]]]]];
    list = Drop[list, list[[1, 2]]]]
][[2, 1]]

Please check this carefully to make certain that it works correctly on your real data.