Skip to main content

functions - Partitioning a list when the cumulative sum exceeds 1


I have a long list of say 1 million Uniform(0,1) random numbers, such as:


 dat = {0.71, 0.685, 0.16, 0.82, 0.73, 0.44, 0.89, 0.02, 0.47, 0.65}

I want to partition this list whenever the cumulative sum exceeds 1. For the above data, the desired output would be:



{{0.71, 0.685}, {0.16, 0.82, 0.73}, {0.44, 0.89}, {0.02, 0.47, 0.65}}



I was trying to find a neat way to do this efficiently with Split combined with say Accumulate or FoldList or Total, but my attempts with Split have not been fruitful. Any suggestions?



Answer




dat = {0.71, 0.685, 0.16, 0.82, 0.73, 0.44, 0.89, 0.02, 0.47, 0.65};

Module[{t = 0},
Split[dat, (t += #) <= 1 || (t = 0) &]
]


{{0.71, 0.685}, {0.16, 0.82, 0.73}, {0.44, 0.89}, {0.02, 0.47, 0.65}}

Credit to Simon Woods for getting me to think about using Or in applications like this.





Performance


I decided to make an attempt at a higher performing solution at the cost of elegance and clarity.


f2[dat_List] := Module[{bin, lns},
bin = 1 - Unitize @ FoldList[If[# <= 1`, #, 0`] & @ +## &, dat];
lns = SparseArray[bin]["AdjacencyLists"] ~Prepend~ 0 // Differences;
Internal`PartitionRagged[dat,
If[# > 0, Append[lns, #], lns] &[Length @ dat - Tr @ lns]
]
]


And a second try at performance using Szabolcs's inversion:


f3[dat_List] :=
Module[{bin},
bin = 1 - Unitize @ FoldList[If[# <= 1`, #, 0`] & @ +## &, dat];
bin = Reverse @ Accumulate @ Reverse @ bin;
dat[[#]] & /@ GatherBy[Range @ Length @ dat, bin[[#]] &]
]

Using SplitBy seems natural here but it tested slower than GatherBy.



Modified October 2018 to use Carl Woll's GatherByList:


GatherByList[list_, representatives_] := Module[{func},
func /: Map[func, _] := representatives;
GatherBy[list, func]
]

f4[dat_List] :=
Module[{bin},
bin = 1 - Unitize @ FoldList[If[# <= 1`, #, 0`] & @ +## &, dat];
bin = Reverse @ Accumulate @ Reverse @ bin;

GatherByList[dat, bin]
]

The other functions to compare:


f1[dat_List] := Module[{t = 0}, Split[dat, (t += #) <= 1 || (t = 0) &]]

fqwerty[dat_List] :=
Module[{f},
f[x_, y_] := Module[{new}, If[Total[new = Append[x, y]] >= 1, Sow[new]; {}, new]];
Reap[Fold[f, {}, dat]][[2, 1]]

]

fAlgohi[dat_List] :=
Module[{i = 0, r},
Split[dat, (If[r, , i = 0]; i += #; r = i <= 1) &]
]

And a single point benchmark using "a long list of say 1 million Uniform(0,1) random numbers:"


SeedRandom[0]
test = RandomReal[1, 1*^6];


fqwerty[test] // Length // RepeatedTiming
fAlgohi[test] // Length // RepeatedTiming
f1[test] // Length // RepeatedTiming
f2[test] // Length // RepeatedTiming
f3[test] // Length // RepeatedTiming
f4[test] // Length // RepeatedTiming
main1[test] // Length // RepeatedTiming (* from LLlAMnYP's answer *)



{6.54, 368130}

{1.59, 368131}

{1.29, 368131}

{0.474, 368131}

{0.8499, 368131}


{0.4921, 368131}

{0.2622, 368131}

I note that qwerty's solution has one less sublist in the output because he does not include the final trailing elements if they do not exceed one. I do not know which behavior is desired.


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],