6
$\begingroup$

I am trying to generate this type of graphic: ε-machine graph

see Fig.1a from https://arxiv.org/abs/0905.3587.

This process is associated with two transition matrices

$$ T^{(0)} = \begin{pmatrix} 0&p&0\\ 1&0&0\\ q&0&0\\ \end{pmatrix} $$ and $$ T^{(1)} = \begin{pmatrix} 0&0&(1-p)\\ 0&0&0\\ 1-q&0&0\\ \end{pmatrix}\,. $$ Their interpretation is that there are 3 causal states, $A,B,C$ that the process can be in (thus the matrices are 3x3) and each matrix element $T^{(x)}_{ij}$ gives the probability of transitioning from causal state $i$ to causal state $j$ while emitting symbol $x$.

So, going back to my question. In Mathematica how can I generate this graph when I input the two matrices, e.g. as in

T = {{{0, p, 0}, {1, 0, 0}, {q, 0, 0}}, {{0, 0, 1 - p}, {0, 0, 0}, {1 - q, 0, 0}}}; 

which has as entries the two transition matrices. Is there a built-in command to do that. If not what are my options?

Here is a question that is fairly similar but not quite the same: a) the transition matrix has real entries instead of abstract symbols $p,q$, and b) there is only one transition matrix.

Any help appreciated!

$\endgroup$
2
  • 1
    $\begingroup$ Do you want to visualize something, or do you want to construct a Graph object which can be used for further analysis? $\endgroup$
    – Szabolcs
    Nov 4 '20 at 12:23
  • $\begingroup$ No, I just want to visualize. $\endgroup$
    – AG1123
    Nov 4 '20 at 12:50
7
$\begingroup$

The defined function is general enough -- it can work with collections of multiple square matrices that have the same dimensions.

Defintion

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/SSparseMatrix.m"]

Clear[TransitionsGraph];

TransitionsGraph[lsTMats : {_?MatrixQ ..}, opts : OptionsPattern[]] :=
    TransitionsGraph[AssociationThread[Range[0, Length[lsTMats] - 1], lsTMats], opts];

TransitionsGraph[aTMats : Association[(_ -> _?MatrixQ) ..], opts : OptionsPattern[]] :=
  Module[{lsStates, aSMats, aAsc, lsRules, EdgeFunc},
   
   lsStates = CharacterRange["A", "Z"][[1 ;; Max[Dimensions /@ Values[aTMats]]]];
   
   aSMats = ToSSparseMatrix[SparseArray[#], "RowNames" -> lsStates, "ColumnNames" -> lsStates] & /@ aTMats;
   
   aAsc = SSparseMatrixAssociation /@ aSMats;
   
   lsRules = 
    Flatten@KeyValueMap[
      Function[{id, asc}, 
       KeyValueMap[DirectedEdge[Sequence @@ #1, Row[{#2, "|", id}]] &, asc]], aAsc];
   
   lsRules = GroupBy[lsRules, #[[1 ;; 2]] &, Grid[List /@ #[[All, 3]]] &];
   lsRules = KeyValueMap[Append, lsRules];
   
   EdgeFunc[el_, ___] := {Black, Thick, Arrow[el, 0.04]};
   
   GraphPlot[lsRules,
    FilterRules[{opts}, Options[GraphPlot]],
    VertexShape -> 
     Map[# -> 
        Graphics[{EdgeForm[{Black, Thick}], FaceForm[{White}], 
          Disk[{0, 0}, 5], 
          Text[Style[#, Italic, FontSize -> 22], {0, 0}]}] &, 
      RowNames[aSMats[[1]]]],
    VertexSize -> 0.08,
    EdgeLabels -> "EdgeTag", 
    EdgeLabelStyle -> Directive[Black, Italic, 20, Background -> White],
    EdgeShapeFunction -> EdgeFunc]
  ];

Examples

TransitionsGraph[{{{0, p, 0}, {1, 0, 0}, {q, 0, 0}}, {{0, 0, 1 - p}, {0, 0, 0}, {1 - q, 0, 0}}}, ImageSize -> 900, 
 GraphLayout -> "SpringElectricalEmbedding"]

Grid[Table[
  Block[{n = RandomChoice[{3, 4, 5}]}, 
   Magnify[#, 0.5] &@
    TransitionsGraph[
     RandomChoice[{9, 1, 1, 1, 1, 1} -> {0, 1, p, q, 1 - p, 
        1 - q}, {RandomChoice[{2, 3}], n, n}], VertexSize -> 0.12, 
     ImageSize -> 900]], 2, 3], Dividers -> All, FrameStyle -> Gray]

enter image description here

$\endgroup$
1
  • 1
    $\begingroup$ Thanks! That's what I was after. $\endgroup$
    – AG1123
    Nov 4 '20 at 15:58
3
$\begingroup$

Something like this:

T = {{{0, p, 0}, {1, 0, 0}, {q, 0, 0}}, {{0, 0, 1 - p}, {0, 0, 
    0}, {1 - q, 0, 0}}}; vars = {x1, x2, x3};
vertexLabels = {1, 2, 3}
edg1 = Outer[Coefficient[#1, #2] &, T[[1]].vars, vars];
edg2 = Outer[Coefficient[#1, #2] &, T[[2]].vars, vars];
edgs = Reap[
    Do[If[edg1[[i, j]] =!= 0, Sow[{i, j, edg1[[i, j]], 1}, e1]];
     If[edg2[[i, j]] =!= 0, Sow[{i, j, edg2[[i, j]], 2}, e2]];, {i, 
      Length[vars]}, {j, Length[vars]}]][[2]];
edgs = Join @@ edgs;
{edges, labels} = Reap[Scan[(Sow[#[[1]] \[DirectedEdge] #[[2]], e1];
       Sow[#[[1]] \[DirectedEdge] #[[2]] -> 
         StringForm["`` | ``", #[[3]], #[[4]]], e2]) &, edgs]][[2]];
Graph[edges, EdgeLabels -> labels, 
 VertexLabels -> Table[i -> vertexLabels[[i]], {i, Length[vars]}], 
 GraphLayout -> "GridEmbedding"]

[1]: https://i.stack.imgur.com/ZOcpQ.png

$\endgroup$
2
  • $\begingroup$ Thanks for the answer! However, first the labels are not quite right; just compare with the figure I attached to my question . Second, in terms of style it looks quite ugly. Any ideas how to fix these? $\endgroup$
    – AG1123
    Nov 4 '20 at 10:31
  • $\begingroup$ Just fixed it. Change the style to your liking. It should not be too hard. $\endgroup$ Nov 4 '20 at 10:35

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.