6
$\begingroup$

So I have a part of transition matrix like this.

 tmat={{0, 0.2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.8, 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.9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.1, 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.2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.8, 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.9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.1}, {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.2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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.9, 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, 0, 0, 0, 0}, {0, 0, 0.2, 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, 1, 0, 0, 
      0, 0, 0}, {0, 0, 0, 0, 0.9, 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, 1, 0, 0, 
      0}, {0, 0, 0, 0, 0, 0, 0.2, 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, 1, 
      0}, {0, 0, 0, 0, 0, 0, 0, 0, 0.9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}};

And I converted this to DiscreteMarkovProcess

mark = DiscreteMarkovProcess[1, tmat];
graph = Graph[mark,EdgeLabels -> {DirectedEdge[i_, j_] :> 
MarkovProcessProperties[mark, "TransitionMatrix"][[i, j]]}];
sp = FindShortestPath[graph, 1, 10]
HighlightGraph[graph, sp]

enter image description here

So is there a simple way to find the shortest path by edge weight, like the path is selected by highest transition probability? For example for 1-> 3, it will go via 14 instead the 2.

Also can we hide or remove the disjointed states like 13, 15 ?

Thanks!

$\endgroup$

1 Answer 1

5
$\begingroup$

Start from base graph:

g = Graph[DiscreteMarkovProcess[1, tmat]];

Remove isolated vertices:

graph = Subgraph[g, Flatten[Select[WeaklyConnectedComponents[g], Length[#] > 1 &]], Options[g]];

Set weights, coords, and label edges (reverse weight value to find highest path):

vcoords = 
 GraphEmbedding[g][[VertexIndex[g, #] & /@ VertexList[graph]]];
weight = MarkovProcessProperties[mark, "TransitionMatrix"][[##]] & @@@
    EdgeList[graph];
wgraph = Graph[graph, EdgeWeight -> 1/weight, 
  EdgeLabels -> Thread[EdgeList[graph] -> weight], VertexCoordinates -> vcoords]; 

sp = FindShortestPath[wgraph, 1, 10]

{1, 14, 3, 4, 5, 18, 7, 8, 9, 10}

HighlightGraph[wgraph, PathGraph[sp, DirectedEdges -> True], 
 GraphHighlightStyle -> "Thick"]
$\endgroup$
2
  • 1
    $\begingroup$ @ halmir this works. Thanks. The plot flipped into mirror image when using Graph[WeaklyConnectedGraphComponents[g][[1]], Options[g]]; Is there way to plot as original? $\endgroup$
    – sdc
    Nov 1, 2017 at 16:53
  • 1
    $\begingroup$ I updated answer. $\endgroup$
    – halmir
    Nov 2, 2017 at 0:53

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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