7
$\begingroup$

For two events say $A$ and $B$, and supposing we have the data: $P(A)$, $P(B)$, $P(A|B)$ and $P(B|A)$, is there a way to generate something like a "probability venn diagram" from this information? The following information online is kind of what I mean:

enter image description here

If there are other ways of visualizing this in Wolfram then I would be interested in those approaches as well.

$\endgroup$
6
$\begingroup$

Usually, this works:

Generating random probabilities:

SeedRandom[12];
(
 Label["Beginning"];
 PA = RandomReal[{0, 1}];
 PB = RandomReal[{0, 1}];
 PAcondB = RandomReal[{0, 1}];
 PAandB = PAcondB PB;
 PBcondA = PAandB/PA;
 If[PB + PA - PAandB > 1. || PBcondA > 1., Goto["Beginning"];];
 )

Determining disks for the events A and B and a region of area 1 that contains both:

rA = Sqrt[PA/Pi];
rB = Sqrt[PB/Pi];
ΩA[x_] := Disk[{-x/2, 0}, rA];
ΩB[x_] := Disk[{x/2, 0}, rB];
F[x_] := Area[RegionIntersection[ΩA[x], ΩB[x]]];
d = x /. FindRoot[F[x] == PAandB, {x, Max[rA, rB] - Min[rA, rB], 0.999999 (rA + rB)}];

union = BoundaryDiscretizeRegion[
   RegionUnion[ΩA[d], ΩB[d]], 
   MaxCellMeasure -> {1 -> 0.01}
];
Ω = TransformedRegion[union, {x, y} \[Function] 1/Sqrt[Area[union]] {x, y}];
Graphics[{
  White, EdgeForm[Black], Ω,
  Opacity[0.5],
  Blue, ΩA[d],
  Red, ΩB[d]
  }]

enter image description here

The shape for the overall probability space is not overly beautiful. Maybe anybody else finds a way to round it off nicely.

$\endgroup$
  • 1
    $\begingroup$ For the shape for the overall probability space you can use BoundingRegion[\[CapitalOmega], "FastEllipse"] (+1 of course) $\endgroup$ – kglr Aug 26 at 5:40
2
$\begingroup$

Given any three of the five magnitudes $P(A), P(B), P(A\cap B), P(A|B), P(B|A)$, the remaining two are determined thru well known relations. We generate the first three randomly.

SeedRandom[777]
{pa, pb} = RandomReal[{0, 1}, 2]

{0.183545, 0.903397}

pab = RandomReal[{0, Min[pa, pb]}]

0.138116

{pbconda, pacondb} = pab/{pa, pb}

{0.752495, 0.152886}

The radii of the two circles that represent the events $A$ and $B$:

{ra, rb} = Sqrt[{pa, pb} / Pi]

{0.241711, 0.536246}

To find how far apart the two circles should be, we can use the function A[R, r, d] from Eric Weisstein - "Circle-Circle Intersection" from MathWorld for the area of the asymmetric lens in the intersection of two circles with radii R and r and centered at {0, 0} and {d, 0}, respectively.

ClearAll[A]
A[R_, r_, d_] :=  r^2 ArcCos[(d^2 + r^2 - R^2)/(2 d r)] + 
  R^2 ArcCos[(d^2 + R^2 - r^2)/(2 d R)] - 
  Sqrt[(-d + r + R) (d + r - R) (d - r + R) (d + r + R)]/2

xd = x /. FindRoot[A[ra, rb, x] - pab, {x, (ra + rb)/2}]

0.421014

Graphics[{EdgeForm[Thick], FaceForm[Opacity[.5]], Red, 
  Disk[{0, 0}, ra], Blue,  Disk[{xd, 0}, rb], FaceForm[Opacity[0]], 
  Disk[{xd/2, 0}, 1/(pa + pb - pab)], 
  Text[Style["A", 16, Black], Offset[{-5, 0}, {-ra, 0}], Right], 
  Text[Style["B", 16, Black], Offset[{5, 0}, {xd + rb, 0}], Left],
  Text[Style["A⋂B", 16, Black], 
   Offset[{-20, 0}, {xd/2, 0}], Center]}]

enter image description here

Verify that the ratios of the intersection to the two disk areas match the given conditional probabilities:

Chop[Norm[
  Area[RegionIntersection[Disk[{0, 0}, ra],  Disk[{xd, 0}, rb]]] /
     {Area[Disk[{0, 0}, ra]], Area[  Disk[{xd, 0}, rb]]} -
   {pbconda, pacondb}], 10^-9]

0

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.