# Rearranging a set of numbers

I have this set of numbers, that is a range of prices (ie 6-10) and a quantity of products (5)

6 - 10:   5
11 - 15:   8
16 - 20:   15
36 - 40:   63
41 - 45:  1
46 - 50:  1
51 - 55:  5
56 - 60:  3
61 - 65:  140
66 - 70:  120
71 - 75:  95
86 - 90:  2
91 - 95:  2
96 - 100:  12
101 - 200:  150
201 - 300:  300
301 - 400:  1
401 - 500:  1
501 - 600:  1
601 - 700:  1
1201 - 1300: 1
1301 - 1400: 1


And I want to obtain ranges like this ones

0 - 60:  111
61 - 65:  140
66 - 70: 120
71 - 100:  111
101 - 200: 150
201 - 300: 300
301 - 1400 : 6


The idea is to obtain less ranges, with similar quantities (grouping the original ones).

Is there any way to do this for any set of ranges? How can I handle the deviation when one number is too high?

-
By what measure or specification are the output ranges determined? Do you give them explicitly, or are they to be selected automatically? – Mr.Wizard May 3 '13 at 18:33
Also, how is your data structured? Is it imported from a file? Is it stored as strings? Or can the above be entered (or is available) in a Mathematica friendly data structure (i.e., without having to do unnecessary manipulations)? – R. M. May 3 '13 at 18:36

Let's start with an easier to work with data format:

data =
{{6, 10, 5}, {11, 15, 8}, {16, 20, 15}, {36, 40, 63}, {41, 45, 1}, {46, 50, 1},
{51, 55, 5}, {56, 60, 3}, {61, 65, 140}, {66, 70, 120}, {71, 75, 95},
{86, 90, 2}, {91, 95, 2}, {96, 100, 12}, {101, 200, 150}, {201, 300, 300},
{301, 400, 1}, {401, 500, 1}, {501, 600, 1}, {601, 700, 1}, {1201, 1300, 1}, {1301, 1400, 1}};


Given this data, and certain assumptions about your goals, you might use something like this:

f[0, {s2_, e2_, t2_}] := {s2, e2, t2}

f[{s1_, e1_, t1_}, {s2_, e2_, t2_}] :=
With[{new = {s1, e2, t1 + t2}},
If[Last@new < 100, new, Sow[new]; 0]
]

Append[#2[[1]], #] & @@ Reap[Fold[f, 0, data]]

{{6, 60, 101}, {61, 70, 260}, {71, 100, 111}, {101, 300, 450}, {301, 1400, 6}}

-
Another option is to use {Interval[...], count} as the structure, and take their union to combine consecutive intervals. I don't have time to work on this, but someone can pick it up if it's viable. – R. M. May 3 '13 at 18:58
@rm-rf I see. One would need to account for the "gap" i.e. union {1, 4} and {5, 8} would be Interval[{1, 4}, {5, 8}]. – Mr.Wizard May 3 '13 at 19:03
Ah, yes... didn't realize OP had discontinuous intervals. Never mind then; will probably be more work than necessary – R. M. May 3 '13 at 19:05

Using Mr.Wizard's ¡EZ-Data! product, here's one approach that takes advantage of the built-in Interval functionality:

data = {{6, 10, 5}, {11, 15, 8}, {16, 20, 15}, {36, 40, 63}, {41, 45, 1}, {46, 50, 1},
{51, 55, 5}, {56, 60, 3}, {61, 65, 140}, {66, 70, 120}, {71, 75, 95}, {86, 90, 2},
{91, 95, 2}, {96, 100, 12}, {101, 200, 150}, {201, 300, 300}, {301, 400, 1},
{401, 500, 1}, {501, 600, 1}, {601, 700, 1}, {1201, 1300, 1}, {1301, 1400, 1}};

curated = Interval[{#1, #2}] -> #3 & @@@ data;
$$range[rng_] := Select[curated, IntervalMemberQ[Interval[rng], First[#]] &];$$total[rng_] := Total[Last /@ $$range[rng]];$$total[{6, 60}]


101

Also:

partition[list_, n_] := Partition[list, n, n, {1, 1}, {}];
partitioned = partition[Sort[curated], 3];
grouped = IntervalUnion[Sequence @@ First /@ #] -> Total[Last /@ #] & /@ partitioned;
Column[grouped]

(* output *)
Interval[{6, 10}, {11, 15}, {16, 20}] -> 28
Interval[{36, 40}, {41, 45}, {46, 50}] -> 65
Interval[{51, 55}, {56, 60}, {61, 65}] -> 148
Interval[{66, 70}, {71, 75}, {86, 90}] -> 217
Interval[{91, 95}, {96, 100}, {101, 200}] -> 164
Interval[{201, 300}, {301, 400}, {401, 500}] -> 302
Interval[{501, 600}, {601, 700}, {1201, 1300}] -> 3
Interval[{1301, 1400}] -> 1


You could of course collapse those intervals (e.g. Interval[is__] :> Interval[{First@First[{is}], Last@Last[{is}]}]). Note the Sort. It's not necessarily needed here, but the point is Intervals have an ordering that makes this sort of thing easier in the general case. (And note that Interval isn't really needed in this last code snippet.)

-

This is not the prettiest code but anyway...

group[data, m] accumulates the quantity values and rounds them down to the nearest multiple of m to collect the intervals into groups.

grouping[data, n] runs group on the data with a range of m values from 70% of n to 130% of n. It then selects the result with the lowest "error" value (where the error is defined as Total[(quantities - n)^2

group[data_, m_] := {#[[1, 1]], #[[-1, 2]], Total@#[[All, 3]]} & /@
SplitBy[Join[data, Accumulate[data[[All, {-1}]]], 2], Floor[Last[#], m] &]

grouping[data_, n_] :=
First@SortBy[group[data, #] & /@ Range[Round[0.7 n], Round[1.3 n]],
Total[(#[[All, -1]] - n)^2] &]


Examples using Mr. Wizard's data:

grouping[data, 100]
(* {{6, 60, 101}, {61, 65, 140}, {66, 70, 120}, {71, 100, 111}, {101, 200, 150}, {201, 1400, 306}} *)

grouping[data, 200]
(* {{6, 65, 241}, {66, 100, 231}, {101, 200, 150}, {201, 1400, 306}} *)

grouping[data, 300]
(* {{6, 70, 361}, {71, 200, 261}, {201, 1400, 306}} *)

-

This looks neat and easy to understand, IMHO:

data = {{6, 10, 5}, {11, 15, 8}, {16, 20, 15}, {36, 40, 63}, {41, 45,
1}, {46, 50, 1}, {51, 55, 5}, {56, 60, 3}, {61, 65, 140}, {66, 70,
120}, {71, 75, 95}, {86, 90, 2}, {91, 95, 2}, {96, 100,
12}, {101, 200, 150}, {201, 300, 300}, {301, 400, 1}, {401, 500,
1}, {501, 600, 1}, {601, 700, 1}, {1201, 1300, 1}, {1301, 1400,
1}};

With[{thresh = 100},
data //. {p : {{_, _, _}} ...,  {s1_, e1_, t1_}, {s2_, e2_, t2_},
rest___} :>
If[t1 + t2 < thresh, {p, {s1, e2, t1 + t2},
rest}, {p, {{s1, e2, t1 + t2}}, rest}]]

(* {{{6, 60, 101}}, {{61, 70, 260}}, {{71, 100, 111}}, {{101, 300,
450}}, {301, 1400, 6}} *)


Edit: I just realised that each element of the output list is list of list of integers, except the last one which might possibly remain a list of integers, but that's easily rectified with Level:

Level[%, {-2}]

(* {{6, 60, 101}, {61, 70, 260}, {71, 100, 111}, {101, 300, 450}, {301,
1400, 6}} *)

-