2
$\begingroup$

This code performs as expected, but it is too scattered and I like to create, if possible, a Mathematica function sayanTest[matrix_, excLst_]:= to do the following by combining Parts 1-4:

ClearAll[dim, mat1, excLst, mat2, MMmat1, mat211, mat212, mat221, 
   mat222, mm0111, mm1011, mm1101, mm1110, nodes, wag];

multiplierB[M_?MatrixQ, 
   sec_Integer] := ((#/Tr[#] & /@ N[M\[Transpose]])\[Transpose] // 
   Take[#, sec, sec] & // Inverse[IdentityMatrix[sec] - #] &);  
select[matrix_, lB_, uB_] := 
   matrix*Map[Boole[lB <= # <= uB] &, matrix, {-1}];

(*Part 1*)
SeedRandom[14];
dim = 15;
mat1 = RandomInteger[{1, 10}, {dim, dim}];
excLst = {5, 3, 1, 2, 4};  (*a specific order of rows and columns*)
MMmat1 = multiplierB[mat1, Length[excLst]];
mat2 = MMmat1[[excLst, excLst]];  (*ordered matrix*)

(*Part 2*)
(*create sub-matrices as block matrices of {5,3} and {1,2,4} *)
mat211 = Take[mat2, 2, 2];  
mat212 = Take[mat2, 2, -3];
mat221 = Take[mat2, -3, 2];
mat222 = Take[mat2, -3, -3];
(*substitute zeros in a sub-matrix*)
mm0111 = ArrayFlatten[{{0, mat212}, {mat221, mat222}}];
mm1011 = ArrayFlatten[{{mat211, 0}, {mat221, mat222}}];
mm1101 = ArrayFlatten[{{mat211, mat212}, {0, mat222}}];
mm1110 = ArrayFlatten[{{mat211, mat212}, {mat221, 0}}];

(*Part 3*)
(*create a weighted digraph using "mat2"*)
nodes = {x1, x2, x3, x4, x5};
wam = select[mat2, .08, .12] /. {0. -> \[Infinity]};
wag = WeightedAdjacencyGraph[nodes, wam];
HighlightGraph[wag, Subgraph[wag, {x5, x3}], VertexLabels -> "Name", 
  GraphHighlightStyle -> "Thick"]

(*Part 4*)
Row[{
   wam2 = select[mm1011, .08, .11] /. {0. -> \[Infinity]};
   wag2 = WeightedAdjacencyGraph[nodes, wam2];
   HighlightGraph[wag2, Subgraph[wag2, {x5, x3}], 
   VertexLabels -> "Name", GraphHighlightStyle -> "Thick"],
   wam3 = select[mm1101, .08, .11] /. {0. -> \[Infinity]};
   wag3 = WeightedAdjacencyGraph[nodes, wam3];
   HighlightGraph[wag3, Subgraph[wag3, {x5, x3}], 
   VertexLabels -> "Name", GraphHighlightStyle -> "Thick"]
  }]

It will be ideal if the weighted digraphs are created with fixed vertex coordinates to make the comparison of the digraphs easy.

$\endgroup$
7
  • 1
    $\begingroup$ do you always break excLst into two parts (that is, do you need to get 4 matrices in step 2)? $\endgroup$
    – kglr
    Feb 11 '21 at 3:08
  • 1
    $\begingroup$ in Part 3, shouldn't select[mat2, .08, .12] be select[mm0111, .08, .12]? $\endgroup$
    – kglr
    Feb 11 '21 at 4:19
  • 1
    $\begingroup$ ... and looks like nodes = {x1, x2, x3, x4, x5} should be nodes = {x5, x3, x1, x2, x4} (to match the indices used to to get mat2)? $\endgroup$
    – kglr
    Feb 11 '21 at 4:29
  • 1
    $\begingroup$ the function parts12 in my answer below allows arbitrary number of parts. $\endgroup$
    – kglr
    Feb 11 '21 at 15:11
  • 1
    $\begingroup$ @kglr: In Part 3, select[mat2,.08, .12] is correct (sorry for my mistake in the title of Part 3, which I edited the post) because with mat2 I wanted to see the graph of the full matrix without any zeros. $\endgroup$ Feb 11 '21 at 15:12
2
$\begingroup$

Parts 1 & 2

ClearAll[waMs]
waMs[matrix_, indexlists_] := Module[{exclst = Flatten @ indexlists, 
   ll = Length @ indexlists, lengths = Length /@ indexlists, m2}, 
  m2 = multiplierB[matrix, Length[exclst]][[exclst, exclst]](* Part 1 *);
  Prepend[m2][ArrayFlatten[MapAt[0 &, TakeList[m2, lengths, lengths], #]] & /@ 
    Tuples[Range @ ll, 2]](*Part 2*)]

Examples:

Using waMs[mat1, {{5, 3}, {1, 2, 4}}] we get OP's mat2, mm0111, mm1011, mm1101 and mm1110:

{mat2, mm0111, mm1011, mm1101, mm1110} == waMs[mat1, {{5, 3}, {1, 2, 4}}]
 True

In the MatrixPlots below white cells show the 0 blocks:

Multicolumn[MatrixPlot /@ waMs[mat1, {{5, 3}, {1, 2, 4}}], 3, 
 Appearance -> "Horizontal"]

enter image description here

Using {{5, 3}, {1, 2, 4}, {6, 7, 8}} as the second argument we get 10 matrices:

Partition[MatrixPlot /@ waMs[mat1, {{5, 3}, {1, 2, 4}, {6, 7, 8}}], 5] // Grid

enter image description here

Parts 3 & 4

ClearAll[waGs]
waGs[lb_: .08, ub_: 0.12][mat_, indexlists_, hl_, vlabels_: Automatic,
   o : OptionsPattern[]] := Module[{wam = select[mat, lb, ub] /. 0. | 0 -> ∞, wag}, 
  wag = WeightedAdjacencyGraph[vlabels, wam, VertexLabels -> "Name", o];
  HighlightGraph[wag, 
   Subgraph[wag, If[vlabels === Automatic, hl, vlabels[[hl]]]], 
   GraphHighlightStyle -> "Thick"]]

Examples:

wams = waMs[mat1, {{5, 3}, {1, 2, 4}}];

hl = {5, 3};

wg0 = waGs[][wams[[1]], {{5, 3}, {1, 2, 4}}, hl, {x1, x2, x3, x4, x5}]

enter image description here

Using waGs with four of the input matrices produced by parts12:

wams = Rest[wams] ;


waGs[.08, .11][#, {{5, 3}, {1, 2, 4}}, hl, {x1, x2, x3, x4, x5}, 
    ImageSize -> Medium, VertexCoordinates -> GraphEmbedding[wg0]] & /@
   wams // Grid[Partition[#, 2], Dividers -> All] &

![enter image description here

Use hl = {1, 2, 4, 5} to get

enter image description here

enter image description here

Further examples:

indexlsts = {{5, 3}, {1, 2, 4}, {6, 7}};
hl = {1, 2, 4, 5};
vnames = {x1, x2, x3, x4, x5, x6, x7};

wams = waMs[mat1, indexlsts];

wg0 = waGs[][wams[[1]], indexlsts, hl, vnames]

enter image description here

waGs[.08, .11][#, indexlsts, hl, vnames, ImageSize -> 200, 
    VertexCoordinates -> GraphEmbedding[wg0]] & /@ wams // 
 Grid[Partition[#, 3], Dividers -> All] &

enter image description here

$\endgroup$
5
  • $\begingroup$ One small question: how can I substitute in the above digraphs the generic nodes {x1,x2,x3,x4,x5} with ` {x1 -> "AGF", x2 -> "OIL", x3 -> "MA1", x4 -> "MA2", x5 -> "EGW"}`? I tried few things but did not succed in. $\endgroup$ Feb 11 '21 at 22:37
  • 1
    $\begingroup$ @TugrulTemel, try VertexReplace[graph, {x1 -> "AGF", x2 -> "OIL", x3 -> "MA1", x4 -> "MA2", x5 -> "EGW"}]? $\endgroup$
    – kglr
    Feb 12 '21 at 0:34
  • $\begingroup$ Yes, it worked. Thanks a lot. $\endgroup$ Feb 12 '21 at 1:17
  • $\begingroup$ When I did wg0 = VertexReplace[waGs[][wams[[1]], lockScenario, {6, 7, 8, 9, 14, 16}], v1] where v1 is the list of new vertex labels, the replacement of the new labels are done but the highlighted edges turn to Default Blue. I lose the red highlighted edges. $\endgroup$ Feb 12 '21 at 1:28
  • 1
    $\begingroup$ @Tugrul, I updated waGs[] to allow specifying vertex labels as the optional 4th argument. $\endgroup$
    – kglr
    Feb 12 '21 at 2:08

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.