ABC analysis in Mathematica

Question

I would like to take a table with columns for the product name and total profit and segment it into three categories. Each category would have ~1/3 of the total profit (for all products). The first category (A) would have ~1/3 of the total profit, and the smallest amount of unique products. The second category (B) would have more products (but less than the third category).

Any thoughts?

Thanks!

Here is an example data set:

 data = {{"product name","profit"},{"item 1",5},{"item 2", 6},{"item 3",4}, {"item 4",2}}

(* and so on *)

(*or in code:*)

data = Prepend[Table[{"item " ~StringJoin~ ToString[i], 
   RandomInteger[100]}, {i, 1, 100}], {"product name", "profit"}]

reference: https://en.wikipedia.org/wiki/ABC_analysis

Answer 1

ClearAll[abcF, pw]
pw = Piecewise[{{"A", # >= 2/3}, {"C", # < 1/3}}, "B"] &;
abcF = pw /@ Normalize[Accumulate @ Sort @ #, Last][[Ordering @ Ordering @ #]] &;

Example:

SeedRandom[1]
n = 30;
data = Prepend[Table[{"item "~StringJoin~ToString[i], RandomInteger[100]}, {i, 1, 
     n}], {"product name", "profit"}];

Use abcF to assign a label to each element of data[[2 ;;, -1]]:

abcF[data[[2 ;;, -1]]]

{"A", "C", "C", "B", "C", "C", "A", "C", "A", "B", "B", "C", "C", \ "C", "A", "A", "A", "B", "C", "C", "C", "C", "C", "B", "B", "C", "C", \ "C", "B", "C"}

Append a column of labels to data:

data2 = Join[data, List /@ Prepend[abcF[data[[2 ;;, -1]]], "ABC"], 2];
Grid[data2]

Update: An alternative approach using Clip:

ClearAll[abcF2, clip]
clip = Clip[#, {1/3, 2/3}, {"C", "A"}] /. _?NumericQ -> "B" &;
abcF2 = clip @ Normalize[Accumulate@Sort@#, Last][[Ordering@Ordering@#]] &;

abcF2[data[[2 ;;, -1]]] == abcF[data[[2 ;;, -1]]]

True

Answer 2

Generate data, leaving off the header.

RandomSeed[1234]; 
data = Table[{"item "~StringJoin~ToString[i], RandomInteger[100]}, {i, 1, 100}];

Sort it on the last column, large to small.

sorted = Reverse@SortBy[data, Last];

Get an accumulation of the last column, and the total.

accum = Accumulate@sorted[[All, 2]];
tot = Last@accum;

Calculate a third of the profits and two-thirds of the profits.

p1 = 1 tot/3;
p2 = 2 tot/3;

Get the indices for the split between A and B, and between B and C

ABindex = First@FirstPosition[accum, x_ /; x > p1];
BCindex = First@FirstPosition[accum, x_ /; x > p2];

Now get the groups.

aa = sorted[[ ;; ABindex-1 ]];
bb = sorted[[ ABindex ;; BCindex-1 ]];
cc = sorted[[ BCindex ;; ]];

Check that each has about a third of the profits

Last@Total@aa
(* 1630 *)
Last@Total@bb
(* 1677 *)
Last@Total@cc
(* 1658 *)

See the differences in their lengths

Length@aa
(* 18 *)

Length@bb
(* 23 *)

Length@cc
(* 59 *)