I am trying to draw a probability tree like this
I have never use tree in Mathematica, therefore, I don't know how to start. How can I draw the above tree? I Know that, using Mathematica calculus the result automatically and exactly.
$\begingroup$ $\endgroup$
7 
2 Answers
$\begingroup$ $\endgroup$
3 A preliminary attempt. You can adjust based on this.
Clear["`*"] makeGraph[vertex_, input_] := Module[{pos}, pos = Position[input[[;; , 1]], vertex[[1]]]; If[pos == {}, {vertex \[DirectedEdge] {Row@ vertex[[2, ;; , 1]], {{""}} }, {Row@vertex[[2, ;; , 1]], {{""}} } \[DirectedEdge] {Times @@ vertex[[2, ;; , 2]], {{StringReplace[ ToString[vertex[[2, ;; , 2]]], {"{1, " -> "", ", " -> "\[Cross]", "}" -> ""}]}} }}, {makeGraph[{input[[pos[[1, 1]], 2]], Append[vertex[[2]], {input[[pos[[1, 1]], 2]], input[[pos[[1, 1]], 3]]}]}, input], makeGraph[{OverBar[input[[pos[[1, 1]], 2]]], Append[vertex[[2]], {OverBar[input[[pos[[1, 1]], 2]]], 1 - input[[pos[[1, 1]], 3]]}]}, input], vertex \[DirectedEdge] {input[[pos[[1, 1]], 2]], Append[vertex[[2]], {input[[pos[[1, 1]], 2]], input[[pos[[1, 1]], 3]]}]}, vertex \[DirectedEdge] {OverBar[input[[pos[[1, 1]], 2]]], Append[vertex[[2]], {OverBar[input[[pos[[1, 1]], 2]]], 1 - input[[pos[[1, 1]], 3]]}]}} ] ] edge[a_] := Last@Last@Last@a makeTree[input_] := GraphTree[TreeGraph@Flatten[makeGraph[{"Start", {{"", 1}}}, input]], TreeElementLabelFunction -> All -> First, ParentEdgeLabelFunction -> All -> edge, TreeLayout -> Left] input = {{"Start", "A", 0.2}, {"A", "B", 0.7}, { \!\(\*OverscriptBox[\("\<A\>"\), \(_\)]\), "B", 0.15}}; makeTree[input] 
- $\begingroup$ Can you match the style, color, font, and sizes too please? $\endgroup$user5601– user56012024-07-27 02:21:41 +00:00Commented Jul 27, 2024 at 2:21
- $\begingroup$ @user5601, your original image was very likely drawn with TikZ in $\TeX$ (see this example). So if you want to have the exact same copy, why don't you just redraw it there instead of in Mathematica? $\endgroup$Domen– Domen2024-07-27 12:46:19 +00:00Commented Jul 27, 2024 at 12:46
- $\begingroup$ @Domen Maybe you want to talk with me. First, I think, Mathematica can draw it and calculate the results easyly. But, see the answer, I don't think so. Now, I can draw it and calculate the results automatically. $\endgroup$minhthien_2016– minhthien_20162024-07-28 03:22:34 +00:00Commented Jul 28, 2024 at 3:22
$\begingroup$ $\endgroup$
For something different:
a = {{0, 0.2, 0.8, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0.7, 0.3, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0.15, 0.85, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0} }; tm = a; Table[tm[[j, j]] = 1, {j, 8, 11}]; dm = DiscreteMarkovProcess[{1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, tm]; s = StationaryDistribution[dm]; p = Probability[x == #, x \[Distributed] s] & /@ {8, 9, 10, 11}; vl = {"Start", "A", "\[Not]A", "A\[And]B", "A\[And]\[Not]B", "\[Not]A\[And]B", "\[Not]A\[And]B"}; pro = Style[Row[{"P{", #1, ")=", #2}], White, Bold] & @@@ Thread[{vl[[-4 ;; -1]], p}]; wg = WeightedAdjacencyGraph[a /. 0 -> Infinity, EdgeLabels -> "EdgeWeight", VertexLabels -> Thread[Range[11] -> (Placed[#, Center] & /@ (Join[vl, pro]))], VertexSize -> 0.7, VertexStyle -> {8 -> Red, 9 -> Red, 10 -> Red, 11 -> Red}] Graph[dm] 
KaryTree[15]... $\endgroup$