FindShortestPath in Markov Transition Matrix

Question

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]

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!

Answer 1

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"]