# Halfing an “array” until only individuals are left

I have created an "array" of sorts using

For[i = 1, i <= Length[vector], i++,
codes[i] = {}
];


The vector is a vector of probabilities, the sum of the vector is 1. I want to start halfing the vector and after each halfing, I want to add a number to the appropriate codes[i] variable. Meaning I half the vector, then I half the halves, etc. etc., until only individuals are left, and that is where the program ends, with each codes[i] filled with appropriate numbers. The halfing is done based on the sums of probabilities, not the length of the vector, so a 6 item vector could be halfed into 2 and 4 items.

I have tried looping the halfing, but of course, it cuts it, assigns numbers, and then starts halfing the first half, and ignores the second, from where it progresses, and only a small part of the vector is done correctly in the end.

total = 1;
sum = 0;
For[i = 1, sum < (total/2), i++,
sum = sum + vector[[i]];
cut = i;
];


To cut a vector in half I run a cycle, summing the probabilities in the vector until the sum is greater or equal to half of what I need. The value of total is 1, because the sum of all the probabilities is 1, therefore I run a cycle adding up until the sum is greater than 0.5, then I save the index of the last number, and I run more cycles that fill the codes[i] vectors with numbers. I fill them with 0s and 1s, so I fill codes[i] with 0s up until the cut variable, then I fill the rest with 1s.

Is it possible to make such a loop, where it completes the entire vector?

• Perhaps an example illustrating how "halving" a vector of probabilities is done will be helpful. – J. M.'s torpor Apr 22 '20 at 13:52
•  total = 1; sum = 0; For[i = 1, sum < (total/2), i++, sum = sum + vector[[i]]; cut = i; ];  I run a cycle, summing the probabilities in the vector until the sum is greater or equal to half of what I need. The value of total is 1, because the sum of all the probabilities is 1, therefore I run a cycle adding up until the sum is greater than 0.5, then I save the index of the last number, and I run more cycles that fill the codes[i] vectors with numbers. I fill them with 0s and 1s, so I fill codes[i] with 0s up until the cut variable, then I fill the rest with 1s. – Drobdien Apr 22 '20 at 14:50
• can you illustrate the steps using vector = {.2, .1, .4, .3}? – kglr Apr 22 '20 at 23:55
• in the first step you find cut=3 and split vector into two pieces vector2 ={{0.2, 0.1, 0.4}, {0.3}}... then what? – kglr Apr 22 '20 at 23:57

ClearAll[splitF, codeF]

splitF = ReplaceRepeated[lst : {_?NumericQ, __?NumericQ} :>
TakeDrop[lst, 1 + LengthWhile[Accumulate[Normalize[lst, Total]], # < .5 &]]];

codeF = Position[splitF@#, {_?NumericQ}] - 1 &;


splitF splits an input list repeatedly until all sublists are singletons. A non-singleton list is first normalized (so that its sum is 1) and accumulated and then split when accumulated total exceeds the threshold .5.

codeF uses the position indices as the code for each singleton sublist.

Examples:

vec1 = {.4, .3, .2, .1};
vec2 = {.3, .3, .2, .1, .1};
vec3 = {.3, .1, .1, .1, .1, .1, .1, .1};
SeedRandom[777]
vec4 = ReverseSort@Normalize[RandomReal[1, 8], Total];

Grid[Prepend[Column /@ {#, splitF@#, codeF@#} & /@ {vec1, vec2, vec3,  vec4},
{"vec", "splitF@vec", "codeF@vec"}], Dividers -> All]


We can pad the codes on the left (by repeating the left-most digit) or right (by repeating the right-most digit) to get equal-length codes:

ClearAll[padLeft, padRight, codeFL, codeFR]

l : {Longest[\[FormalX] ..], a_, b___} :> (l /. \[FormalX] -> a) &;

l : {b___, a_, Longest[\[FormalX] ..]} :> (l /. \[FormalX] -> a) &;

codeFL = padLeft[Position[splitF@#, {_?NumericQ}] - 1] &;

codeFR = padRight[Position[splitF@#, {_?NumericQ}] - 1] &;
Grid[Prepend[Column/@ {#, splitF @ #,  codeF @ #, codeFL @ #, codeFR @ #} & /@
{vec1, vec2, vec3, vec4},
{"vec", "splitF@vec", "codeF@vec", "codeFL@vec", "codeFR@vec"}], Dividers -> All]


SeedRandom[777]
vec5 = ReverseSort@Normalize[RandomReal[1, 30], Total];

Row[ArrayPlot[ToExpression[#] @ vec5, PlotLabel -> Style[#, 16],
ImageSize -> 1 -> 20,
FrameTicks -> {{Transpose[{Range @ Length @ vec5,
Row /@ ToExpression[#] @ vec5}], None},
{All, All}}] & /@
{"codeF", "codeFL", "codeFR"},
Spacer[20]]


• Could you please explain the first block of code? From 'Clear All' to 'codeFR'. – Drobdien Apr 25 '20 at 5:03
• @Drobdien, added a few notes. Hope this helps. – kglr Apr 25 '20 at 5:38