# Efficient binarization of a list

I am generating a list of 1's, 2's, and 3's with different probabilities for each number. I then convert this list into three binarized lists, giving a list of the locations of each digit in the original list. There must be a more efficient way to do this? Perhaps changing the way I make the original list?

list = RandomChoice[{0.5, 0.3, 0.2} -> {1, 2, 3}, 20]
list1 = ReplacePart[ReplacePart[ReplacePart[list, Position[list, 2] -> 0],
Position[list, 3] -> 0], Position[list, 1] -> 1]
list2 = ReplacePart[ReplacePart[ReplacePart[list, Position[list, 1] -> 0],
Position[list, 3] -> 0], Position[list, 2] -> 1]
list3 = ReplacePart[ReplacePart[ReplacePart[list, Position[list, 1] -> 0],
Position[list, 2] -> 0], Position[list, 3] -> 1]

• Most answers assume one needs to generate list as the OP does, but he explicitly asks whether a different method of generation might be faster. I think there is (see below). – David G. Stork Feb 7 '18 at 22:15
• Does "OP" stand for opening paragraph? – Michael B. Heaney Feb 7 '18 at 23:23
• @Michael B. Heaney No, 'original poster' (the person who started the thread) or 'original post'. – No don't shown my real name Feb 8 '18 at 0:43

This is very fast and avoids an intermediate step of creating 1s, 2s and 3s:

mylist = RandomChoice[{.3, .2, .5} -> {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}, 300];
Transpose[mylist]


The generation of the list and the result is about twice as fast as the generation of the list and the result in the fastest method described by others here.

As @CarlWolf points out, using a PackedArray speeds things too:

Timing[mylist =
DeveloperPackedArray[
RandomChoice[{.3, .2, .5} -> {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}},
10^8]];
Transpose[mylist];]


{4.04332, Null}

• For optimal efficiency with this method, you should include DeveloperToPackedArray in appropriate places. Otherwise it is far slower than the other packed array methods for large lists. – Carl Woll Feb 8 '18 at 1:01
• Yes... PackedArrays will help... just as they'll help a number of other proposed solutions. – David G. Stork Feb 8 '18 at 1:02
• I'm just pointing out that your statement that your answer is the fastest is not correct for long lists. – Carl Woll Feb 8 '18 at 1:09
• $10,000,000$ samples in 1.5 seconds should be fast enough for anyone, though. – David G. Stork Feb 8 '18 at 1:12
• I'm just surprised that the output of RandomChoice isn't a packed array by default... – Sjoerd Smit Feb 8 '18 at 11:18

Edit:

@CarlWoll brought to my attention that RandomChoice may produce unpacked arrays. This is why I update the timings. Previously, I stated that Carls' solutiuon need ten times as long as the first proposal below. This is not true for PackedArrays. Mea culpa.

list = DeveloperToPackedArray[RandomChoice[{0.5, 0.3, 0.2} -> {1, 2, 3}, 200000]];


Another very efficient possibility is

RepeatedTiming[
list1a = Subtract[1,Unitize[Subtract[list,1]]];
list2a = Subtract[1,Unitize[Subtract[list,2]]];
list3a = Subtract[1,Unitize[Subtract[list,3]]];
][]


0.00069

This is still a bit faster than @Carl's proposal:

RepeatedTiming[
list1b = Unitize@Clip[list, {1, 1}, {0, 0}];
list2b = Unitize@Clip[list, {2, 2}, {0, 0}];
list3b = Unitize@Clip[list, {3, 3}, {0, 0}];
][]


0.00217

Other notable ways to do it:

Using SparseArray (not so efficient):

{list1c,list2c,list3c} = Normal[SparseArray[
Transpose[{list,Range[Length[list]]}]->1,
{3,Length[list]}
]]; // RepeatedTiming // First


0.082

Another nice way is

{list1d, list2d, list3d} = Transpose[IdentityMatrix[[list]]]; // RepeatedTiming // First


0.0032

• Your list is unpacked, which is why Clip is slow. – Carl Woll Feb 7 '18 at 21:51
• @CarlWoll I am sorry! I updated the timings in the meantime... – Henrik Schumacher Feb 7 '18 at 22:14
• My timings on OSX with M11.2 are much closer, with the Clip approach becoming faster with larger array sizes (e.g., 10^6 or 10^7). – Carl Woll Feb 7 '18 at 22:40

There are many possibilities, but I like using Clip:

Unitize@Clip[list,{1,1},{0,0}]
Unitize@Clip[list,{2,2},{0,0}]
Unitize@Clip[list,{3,3},{0,0}]


{0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0}

{0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1}

{1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0}

If your lists consist of just integers, than a compiled version is possible, e.g.:

fc = Last @ Compile[{{d, _Integer, 1}, {t,_Integer}},
Table[Boole[CompileGetElement[d, i]==2], {i, Length@d}],
CompilationTarget->"C",
RuntimeOptions->"Speed"
];


Comparison:

lst = DeveloperToPackedArray @ RandomChoice[{.5,.2,.3}->{1,2,3}, 10^7];

r1 = fc[lst, 2]; //RepeatedTiming
r2 = BitXor[1, Unitize @ BitXor[2, lst]]; //RepeatedTiming

r1 === r2


{0.042, Null}

{0.0614, Null}

True

Update: On Wolfram Cloud, the timing comparison I get is the opposite of David's claim that "the result is about twice as fast as the generation of the list and the result in the fastest method described by others here"; that is, to my surprise, BitXor-based method is more than 2x faster than David's method. Using RandomVariate+ EmpiricalDistribution + WeightedData combination instead of RandomChoice improves the timings. Using IdentityMatrix as suggested by @Carl, the timings for David's method improve significantly but they are still no better than the timings for BitXor-based methods.

ClearAll[f1,f2,f3,f4]
f1[n_]:= Module[{lst=DeveloperToPackedArray@RandomChoice[{0.5, 0.3, 0.2}->{1, 2, 3}, n]},
BitXor[1, Unitize[BitXor[#, lst] & /@ {1, 2, 3}] ]]
f2[n_]:= Module[{lst=DeveloperToPackedArray[ RandomVariate[
EmpiricalDistribution[WeightedData[Range, {.5, .3, .2}]], n]]},
BitXor[1, Unitize[BitXor[#, lst] & /@ {1, 2, 3}] ]]
f3[n_]:= Transpose[DeveloperToPackedArray@RandomChoice[{.3, .2, .5} ->
{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}, n]]
f4[n_]:= Transpose[DeveloperToPackedArray@RandomChoice[{.3, .2, .5} ->
IdentityMatrix, n]]

funcs = {f1, f2, f3, f4};
timings = Prepend[Table[Prepend[Table[First[RepeatedTiming[funcs[[j]][i]]],
{j, 1, 4}], i], {i, {200000, 10^6}}], {"n", "f1","f2","f3", "f4"}];
Grid[timings, Dividers -> All] // TeXForm


$\begin{array}{|c|c|c|c|c|} \hline \text{n} & \text{f1} & \text{f2} & \text{f3} & \text{f4} \\ \hline 200000 & 0.0069 & 0.0061 & 0.016 & 0.0063 \\ \hline 1000000 & 0.0359 & 0.032 & 0.0885 & 0.035 \\ \hline \end{array}$

(I cannot time larger lists because the required computation exceeds the memory limit of the free cloud accounts.)

{l1, l2, l3} = BitXor[1, Unitize[BitXor[#, list] & /@ {1, 2, 3}] ]

TeXForm @ {list, l1, l2, l3}


$\left( \begin{array}{cccccccccccccccccccc} 1 & 1 & 1 & 1 & 1 & 2 & 3 & 1 & 2 & 1 & 1 & 1 & 2 & 3 & 2 & 1 & 1 & 1 & 3 & 2 \\ 1 & 1 & 1 & 1 & 1 & 0 & 0 & 1 & 0 & 1 & 1 & 1 & 0 & 0 & 0 & 1 & 1 & 1 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 & 1 & 0 & 0 & 0 & 1 & 0 & 1 & 0 & 0 & 0 & 0 & 1 \\ 0 & 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 & 0 & 1 & 0 \\ \end{array} \right)$

Timings: Using Henrik's setup, this is twice as fast as Henrik's method.

list = DeveloperToPackedArray[RandomChoice[{0.5, 0.3, 0.2} -> {1, 2, 3}, 200000]];

RepeatedTiming[{l1, l2, l3} = BitXor[1, Unitize[BitXor[#, list] & /@ {1, 2, 3}] ]][]


0.0013

RepeatedTiming[list1a = Subtract[1, Unitize[Subtract[list, 1]]];
list2a = Subtract[1, Unitize[Subtract[list, 2]]];
list3a = Subtract[1, Unitize[Subtract[list, 3]]];][]


0.0025

RepeatedTiming[list1b = Unitize@Clip[list, {1, 1}, {0, 0}];
list2b = Unitize@Clip[list, {2, 2}, {0, 0}];
list3b = Unitize@Clip[list, {3, 3}, {0, 0}];][]


0.0027

And @@ (Equal @@@
Transpose[{{list1a, list2a,  list3a}, {list1b, list2b,  list3b}, {l1, l2, l3}}])


True

• As I mentioned in a comment to @DavidGStork's answer, using IdentityMatrix instead of {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}} improves the speed of his answer significantly. – Carl Woll Feb 8 '18 at 5:15
• @Carl, thank you. Was about to post the timing for that version. – kglr Feb 8 '18 at 5:23

Using ReplaceAll (/.) and delayed rules for pattern matching, this can be done much more directly:

l1 = list /. (x_?NumericQ :> If[x == 1, 1, 0])
l2 = list /. (x_?NumericQ :> If[x == 2, 1, 0])
l3 = list /. (x_?NumericQ :> If[x == 3, 1, 0])


The ?NumericQ is primarily there to avoid catching List in the replacement as well.

You could also map a suitable replacement function over the list:

l1 = If[# == 1, 1, 0] & /@ list
l2 = If[# == 2, 1, 0] & /@ list
l3 = If[# == 3, 1, 0] & /@ list

list1e = Boole[# == 1] & /@ list;
list2e = Boole[# == 2] & /@ list;
list3e = Boole[# == 3] & /@ list;


another option is using Piecewise. For example:

fun[x_] := Piecewise[{{1, x == 1}}, 0]
SetAttributes[fun, Listable]
list1c = fun[list];


or the combination Reap/Scan:

list1d = Reap[Scan[If[# == 1, Sow, Sow] &, list]][[2, 1]];