The following code
generates:
The first element is a layered graph of the original system sam
. The second element is a list of all the pathways from L
to G
. The third element is a directed graph in which the extracted pathways are highlighted. The fourth element is this highlighted subgraph. I like to achieve the following:
In the first element
LayeredGraph
, edge weights should be placed on each edge with properly distanced edge lengths. Currently, the edge betweenA
andL
does not appear properly.The fourth element should be formatted like the first layered graph. Currently, vertex names inside circles and edge weights are all missing.
Here is what I have developed:
ClearAll[vnames, sam];
vnames = {"A", "X", "Q", "L", "K", "H", "G", "CA", "YTAX", "STAX", "TAR", "ROW"};
sam = {{0, PX QX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, PD QD, 0, 0, 0, 0,
0, 0, 0, -TE, exr pwe QE}, {PQ QINT, 0, 0, 0, 0, PQ QH, PQ QG,
PQ QINV, 0, 0, 0, 0}, {PL QL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {PK QK, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, PL QL,
PK QK, 0, TR[H, g], 0, 0, 0, 0, exr TR[H, rw]}, {0, 0, 0, 0, 0, 0,
0, 0, YTAX, STAX, TAR, exr TR[g, rw]}, {0, 0, 0, 0, 0,
s YH (1 - t[H]), SAV[g], 0, 0, 0, 0, exr SAV[rw]}, {0, 0, 0, 0, 0,
YH t[H], 0, 0, 0, 0, 0, 0}, {0, 0, STAX, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {0, 0, TM, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, exr pwm QM, 0, 0,
0, 0, 0, 0, 0, 0, 0}};
(*from @KGLR*)
edgeW = Module[{g = #,
e = DirectedEdge @@@ Partition[#, 2, 1] & /@
FindPath[##, \[Infinity], All]},
Transpose[{e, PropertyValue[{g, #}, EdgeWeight] & /@ # & /@ e}]] &;
subGraphF = Module[
{el = edgeW[##][[All, 1]]},
Graph[DeleteDuplicates[Flatten@el],
VertexCapacity -> {v_ :> PropertyValue[{#, v}, VertexCapacity]},
EdgeWeight -> {e_ :> PropertyValue[{#, e}, EdgeWeight]}]] &;
wag = WeightedAdjacencyGraph[vnames,
Transpose@sam /. {0 -> \[Infinity]}, VertexLabels -> "Name",
EdgeLabels -> "EdgeWeight", ImageSize -> 300];
source = "L";
sink = "G";
{
LayeredGraphPlot[{"A" -> "Q", "A" -> "L", "A" -> "K", "X" -> "A",
"Q" -> "X", "Q" -> "STAX", "Q" -> "TAR", "Q" -> "ROW", "L" -> "H",
"K" -> "H", "H" -> "Q", "H" -> "CA", "H" -> "YTAX", "G" -> "Q",
"G" -> "H", "G" -> "CA", "CA" -> "Q", "YTAX" -> "G", "STAX" -> "G",
"TAR" -> "X", "TAR" -> "G", "ROW" -> "X", "ROW" -> "H",
"ROW" -> "G", "ROW" -> "CA"}, Left, VertexLabeling -> True,
EdgeRenderingFunction -> ({Brown, Arrow[#1, 0.4]} &),
VertexRenderingFunction -> ({LightGray, EdgeForm[Black],
Disk[#, .3], Black, Text[#2, #1]} &), ImageSize -> 400],
TableForm[edgeW[wag, source, sink]],
HighlightGraph[wag, subGraphF[wag, source, sink],
GraphHighlight -> {source, sink}, ImageSize -> 400,
EdgeLabels -> "EdgeWeight"],
subGraphF[wag, source,
sink] (* all paths from source to sink: a subgraph *)
}