Skip to main content
3 of 5
added 2421 characters in body
kglr
  • 403.4k
  • 18
  • 501
  • 959

Update:

ClearAll[grapH, combinedGraph] grapH[mat_, dir_: "Column"][t_, v_, opts : OptionsPattern[Graph]] := Module[{vertices = CharacterRange["A", "Z"][[;; Length@mat]], comp = dir /. {"Column" -> VertexInComponent, "Row" -> VertexOutComponent}, gf = dir /. {"Column" -> AdjacencyGraph, "Row" -> ReverseGraph@*AdjacencyGraph}, g}, g = gf[vertices, Transpose[UnitStep[Normalize[#, Total] - t] & /@ Transpose[mat]]]; Subgraph[g, comp[g, v], opts]]; combinedGraph[mat_, t_, v_, opts : OptionsPattern[Graph]] := Module[{el = EdgeList /@ {grapH[Transpose@mat, "Row"][t, v], grapH[mat][t, v]}, complement, intersection}, complement = Complement @@ el; intersection = Intersection @@ el; SetProperty[EdgeAdd[grapH[mat][t, v], complement], {EdgeStyle -> {_ :> Blue, Alternatives @@ intersection -> Dashed, Alternatives @@ complement -> Red}, opts}]] 

Examples:

vc = Thread[vertices -> GraphEmbedding[GridGraph[{2, 2}]]]; Row[MapThread[grapH[## & @@ #][.25, "A", VertexShapeFunction -> "Name", VertexCoordinates -> vc, ImageSize -> {400, 400}, EdgeStyle -> #2, PlotLabel -> Grid[{{"mat", "direction", "threshold", "starting\nnode"}, {MatrixForm[First@#], #[[2]], t, "A"}}, Dividers -> All]] &, {{{mat, "Column"}, {Transpose@mat, "Row"}}, {Blue, Red}}]] 

enter image description here

Row[MapThread[grapH[## & @@ #][.25, "C", VertexShapeFunction -> "Name", VertexCoordinates -> vc, ImageSize -> {400, 400}, EdgeStyle -> #2, PlotLabel -> Grid[{{"mat", "direction", "threshold", "starting\nnode"}, {MatrixForm[First@#], #[[2]], t, "C"}}, Dividers -> All]] &, {{{mat, "Column"}, {Transpose@mat, "Row"}}, {Blue, Red}}]] 

enter image description here

Row[combinedGraph[mat, .25, #, VertexShapeFunction -> "Name", VertexCoordinates -> vc, PlotLabel -> Grid[{{"threshold : ", .25}, {"starting node: ", #}}], ImageSize -> 200] & /@ {"A", "B", "C", "D"}] 

enter image description here

Original answer:

ClearAll[grph] grph[mat_, t_, v_, opts : OptionsPattern[Graph]] := Module[{vertices = CharacterRange["A", "Z"][[;; Length@mat]], assoc, edges, g}, assoc = AssociationThread[vertices, UnitStep[Normalize[#, Total] - t] & /@ Transpose[mat]]; edges = Join @@ KeyValueMap[Thread[DirectedEdge[#, vertices[[Flatten@#2]]]] &][ Position[#, 1] & /@ assoc]; g = Graph[edges]; Subgraph[g, VertexOutComponent[g, v], VertexLabels -> "Name", opts]]; 

Examples:

Using mat and Transpose @ mat as the first argument:

Row[Panel /@ MapThread[grph[#, .25, "A", ImageSize -> 300, EdgeStyle -> #2, PlotLabel -> MatrixForm[#]] &, {{mat, Transpose@mat}, {Blue, Red}}]] 

enter image description here

To show the two graphs for mat and Transpose@mat together:

edgeadd = Complement[EdgeList@grph[Transpose@mat, .25, "A", EdgeStyle -> Red], EdgeList@grph[mat, .25, "A"]]; SetProperty[EdgeAdd[grph[mat, .25, "A"], edgeadd], EdgeStyle -> {_ -> Blue, Alternatives @@ edgeadd -> Red}] 

enter image description here

Several combinations of thresholds and starting nodes:

Grid[Outer[ grph[mat, #, #2, ImageSize -> 200, PlotLabel -> Grid[{{"threshold :", #}, {"starting node : ", #2}}]] &, {.1, .25, .3}, {"A", "B", "C"}], Dividers -> All] 

enter image description here

kglr
  • 403.4k
  • 18
  • 501
  • 959