Sheldon Ross 10: Exercise 2.28 – Making a biased system useful!


Question

Suppose that we want to generate a random variable \(X\) that is equally likely to be either 0 or 1, and that all we have at our disposal is a biased coin that, when flipped, lands on heads with some (unknown) probability p. Consider the following procedure:

  1. Flip the coin, and let 01, either heads or tails, be the result
  2. Flip the coin again, and let 02 be the result
  3. If 01 and 02 are the same, return to step 1
  4. If 02 is heads, set \(X = 0\), otherwise set \(X = 1\)
Objectives

Show that the random variable \(X\) generated by this procedure is equally likely to be either 0 or 1


Analytical Solution

The way to approach this is a follows. We would be needing to use conditional probability here. We are looking for the cases where both the elements in the pair are different and hence the probability that X equals 0 turns out to be \[ P\{ X = 0 \} = P \{ (t, h)|(t, h) or (h, t) \} = \frac{p(1-p)}{2p(1-p)} = \frac{1}{2} \] Same goes for \(P\{ X = 1 \}\) which is again \(\frac{1}{2}\)


Simulations

I have written this section first before I wrote the Analytical Part. The idea of creating a extracting an unbiased outcome from an biased coin/system is quite an exciting one. The following is the outcome for a system with two(or more) outcomes. Note that the probabilities are decided randomly by the function called “randomWeights” and its definition is shown below in the code section. Do have a look at it.

Reading the grid: Observe that the numbers are arranged as grids. These are the pairs( triples, quadruplets, .. ) represented in the problem. The framed pairs are the ones that have been selected. Also, only the second number from the framed set is used as an outcome. The ones not selected are greyed out and struck-through. Notice how many of the tosses we lose in the process. We lose all the “equal pairs” and we also only select the last element from the selected “unequal pairs”. In all these runs, the the system was “tossed” for 1000 times.

We will observe some simulations of biased systems with 2 and more outcomes. Notice how the number of usable runs decreases as the number outcomes of the biased system increases.


Biased-System with 2 outcomes

Biased-System with 3 outcomes

Biased-System with 4 outcomes

Bar Charts

These are the charts plotted from the selected “usable” groups out of the 10 million trials. Notice how the usability decreases with the number of possible outcomes increases. Also, see that since the usable outcomes themselves are small for higher outcomes, it takes longer for the distribution to even appear to be uniform.

Example: For 10 possible outcomes, only 53 flips are usable out of 10 Million. That is a lot of waste 😯 !!


ClearAll[randomWeights, fairStyle, biasedFlips]

randomWeights[r_] :=
 RandomSample[Range[r]]/Total[Range[r]] ->
  ToUpperCase[Alphabet[]][[1 ;; r]]

fairStyle[list_List] := Module[{newList = list},
  newList = list;
  If[Union[list] == Sort[list],

   newList[[Length[list]]] =
    Style[Last@newList, Blue, Bold, Background -> LightBlue];
   Framed@Style[stringJoinStyled[newList, " "], Darker@Green],
   Style[stringJoinBuffer[newList, " "], GrayLevel[0.8],
    FontVariations -> {"StrikeThrough" -> True}]]
  ]

biasedFlips[r_, sample_: 10000000] :=
 Module[{data = Partition[RandomChoice[randomWeights[r], sample], r],
   plotLabel, usable},
  data = Counts[Last[#] & /@ Select[data, Union[#] == Sort[#] &]];
  usable = Plus @@ data;
  plotLabel = StringJoin @@ {ToString@r, " outcomes: usable flips = ",
     ToString@usable, " of ", ToString@sample, " = ",
     ToString@N[usable*100/sample], " %"};
  plotLabel = Style[plotLabel, 10, Darker@Green];
  BarChart[data, ChartLabels -> Automatic,
   LabelingFunction -> (Placed[#, Above] &), PlotLabel -> plotLabel]
  ]

Module[{plot = biasedFlips[#]},
   Export[StringReplace[NotebookFileName[], ".nb" -> "_" <> ToString[#]
       <> "_outcomes_barChart.svg"], plot]] & /@ Range[2, 10]

With[{image =
     Grid@Partition[
       fairStyle /@ Partition[RandomChoice[Range[#], 1500], #], 8]},
   Export[StringReplace[NotebookFileName[],
     ".nb" -> "_grid_0" <> ToString[#] <> ".svg"], image,
    ImageSize -> 788, ImageResolution -> 1200]] & /@ Range[2, 4]

Code snippet

The loaded function stringJoinStyled used in the codes above can be found from the snippet below