3
$\begingroup$

Given a matrix mat:

mat = {{1, 5, 2, 6}, {4, 3, 4, 1}, {0, 1, 4, 0}, {2, 1, 3, 4}};

I want to apply the following conditions to generate various directed graphs.

  1. Denote columns by A, B, C, D
  2. Choose a column, say A (1st column), and find the binary relations between A and those cells with a number higher than 25% (threshold) of the respective column total. For example, for column A, BA and DA will be selected as the ratios (4/7 and 2/7) will be higher than 25%, respectively.
  3. Then choose column B because we obtained BA at step 2 and repeat the same procedure at step 2 to find those relations above 25% of the total of column B; next do the same operation for the second relation obtained in step 2, which is DA.
  4. Next, choose column C and follow the same operations in step 2 end so on...
  5. Generate a directed graph of all the significant relations obtained from the matrix mat.

After completing the visits to all of the columns, then apply the same steps (1-4 above) to the transpose of the matrix mat to generate another directed graph of the resulting relations.

I want to generate:

  1. two directed graphs: one for column-wise operation (subgraph1) and another for row-wise operation (subgraph2) and
  2. another directed graph combining the two directed graphs in (1) with different colors to differentiate the column-wise and row-wise graphs.

I like to produce these directed graphs using a function f[mat,th,column#] for automated generation of the directed graphs using mat by choosing a specific column (for example, A as column#) and a given threshold th, and another function g[subgraph1, subgraph2, column#]to combine the individual graphs.

UPDATE Below, I update the question with an example explaining the steps for the code development.

Starting node A:

enter image description here

Starting node B:

enter image description here

Staring node C:

enter image description here

Starting node D:

enter image description here

$\endgroup$
  • 2
    $\begingroup$ Please include the actual graph (output) that you expect for the example matrix. This would greatly clarify the question. $\endgroup$ – Bob Hanlon Nov 23 '19 at 14:15
  • $\begingroup$ @Bob Hanlon: Yes, indeed. I will update my question with the expected output. $\endgroup$ – Tugrul Temel Nov 23 '19 at 14:45
4
+50
$\begingroup$

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:

mat = {{1, 5, 2, 6}, {4, 3, 4, 1}, {0, 1, 4, 0}, {2, 1, 3, 4}};
vertices = {"A", "B", "C", "D"};
vc = Thread[vertices -> GraphEmbedding[GridGraph[{2, 2}]]];  
t = .25;


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

| improve this answer | |
$\endgroup$
  • $\begingroup$ Very very nice...Now I will try to digest your heavy code. Thanks a lot. $\endgroup$ – Tugrul Temel Nov 24 '19 at 0:51
  • $\begingroup$ When we combine two separate graphs, I lose track of the information on the edges that are present in both graphs. Would it possible to indicate with dashed lines those edges appearing in both graphs at the same time? $\endgroup$ – Tugrul Temel Nov 24 '19 at 12:25
  • 1
    $\begingroup$ @TugrulTemel, re "edges appearing in both graphs", you can use complement = Complement[ EdgeList@grph[Transpose@mat, .25, "A", EdgeStyle -> Red], EdgeList@grph[mat, .25, "A"]]; intersection = Intersection[ EdgeList@grph[Transpose@mat, .25, "A", EdgeStyle -> Red], EdgeList@grph[mat, .25, "A"]]; SetProperty[EdgeAdd[grph[mat, .25, "A"], edgeadd], EdgeStyle -> {_ :> Blue, Alternatives @@ intersection -> Dashed, Alternatives @@ complement -> Red}]. Re direction of the edge b/w "C" and "B", it is more likely that I missed/misunderstood something. $\endgroup$ – kglr Nov 24 '19 at 13:39
  • 1
    $\begingroup$ @Tugrul, maybe you can try vc = Thread[vertices -> GraphEmbedding[GridGraph[{4, 5}]]][[;;Length[vertices]]]? $\endgroup$ – kglr Nov 28 '19 at 0:33
  • 1
    $\begingroup$ I had a misplaced ]; the correct form is vc = Thread[vertices -> GraphEmbedding[GridGraph[{4, 5}]][[;; Length[vertices]]]]. $\endgroup$ – kglr Nov 28 '19 at 23:54

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.