Sheldon Ross 10: Exercise 3.67

Question: A coin having probability p of coming up heads is continually flipped. Let Pj(n) denote the probability that a run of j successive heads occurs within the first n flips.

  1. Argue that Pj(n) = Pj(n − 1) + pj (1 − p)[1 − Pj(n − j − 1)]
  2. By conditioning on the first non-head to appear, derive another equation relating Pj(n) to the quantities Pj(n − k), k = 1, . . . , j.

Analytical Solution

Since this is purely a theoretical exercise, we will look at the simulation aspect of this.


Simulation Solution

The way this is going was simulated is as follows. We generate a sequence of 100 bits (Heads(1) or Tails(0)) where the probability of Heads (or winning) is ‘p’. We find the lengths of subsequences that contains 1. For example, if our original sequence is 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 0, 1, 0, 1, 1, 1: then the lengths of the subsequences that contain 1 are 1, 3, 4, 1, 3. This is the first level of processing. Then, we find the total number of times these sub-sequences have repeated.

So, of 1, 3, 4, 1, 3

  • 1 has appeared 2 times
    • on the plot, this would be x = 1 and y = 2
  • 2 has appeared 2 times
    • on the plot, this would be x = 2 and y = 2
  • 3 has appeared 3 times
    • on the plot, this would be x = 3 and y = 1

Why is there so much scatter in the plot? This is because the coordinates have been intentionally randomized to show the density of across the canvas. This is similar to what has been done in exercise 3.63 found here

 


Code

ClearAll[associationRandomizer];
associationRandomizer[association_?AssociationQ, offset_Real : 0.3] :=
    Module[{mapRange = Length@association},
      MapThread[{#1 + Cos[#4] #3, #2 + Sin[#4] #3} &, {Keys@association,
        Values@association,
        RandomVariate[NormalDistribution[0, offset], mapRange],
        RandomReal[{-\[Pi], \[Pi]}, mapRange]}]]

Module[{p = 0.5, length = 100, plotExtent = 25, iterations = 10000},
  ListPlot[
    associationRandomizer[#, 0.5] & /@
        Table[(Counts[
          Length /@ Cases[#, {1 ..}] &[
            Split@RandomChoice[{p, 1 - p} -> {1, 0}, length]]]),
          iterations], AspectRatio -> 1,
    PlotRange -> {{0, plotExtent}, {0, plotExtent}}, ImageSize -> 788,
    PlotStyle -> {{Opacity@0.2, PointSize@0.001, Lighter@Blue}},
    Frame -> True, GridLines -> ConstantArray[Range[plotExtent], 2],
    GridLinesStyle -> LightGray,
    FrameLabel -> (Style[#, 14] & /@ {"Length of continuous wins",
      "Number of occurrences"})]
]

Grid[Partition[
  Table[Module[{p = r, length = 100, plotExtent = 15,
    iterations = 10000},
    ListPlot[
      associationRandomizer[#, 0.5] & /@
          Table[(Counts[
            Length /@ Cases[#, {1 ..}] &[
              Split@RandomChoice[{p, 1 - p} -> {1, 0}, length]]]),
            iterations], AspectRatio -> 1,
      PlotRange -> {{0, plotExtent}, {0, plotExtent}},
      ImageSize -> 263,
      PlotStyle -> {{Opacity@0.25, PointSize@0.001, Darker@Hue@r}},
      Frame -> True, (*GridLines\[Rule]ConstantArray[Range[plotExtent],
     2]*)GridLinesStyle -> LightGray]
  ], {r, 0.1, 0.9, 0.1}], 3]]

End of the post


.

.

.

.

.

.

.

.

.

.

.

.

.

.

.

.

.

.