# Constructing weighted directed graphs of sub-matrices of a matrix

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;
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]};
HighlightGraph[wag, Subgraph[wag, {x5, x3}], VertexLabels -> "Name",
GraphHighlightStyle -> "Thick"]

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

• do you always break excLst into two parts (that is, do you need to get 4 matrices in step 2)?
– kglr
Feb 11, 2021 at 3:08
• in Part 3, shouldn't select[mat2, .08, .12] be select[mm0111, .08, .12]?
– kglr
Feb 11, 2021 at 4:19
• ... 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)?
– kglr
Feb 11, 2021 at 4:29
• the function parts12 in my answer below allows arbitrary number of parts.
– kglr
Feb 11, 2021 at 15:11
• @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. Feb 11, 2021 at 15:12

### 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"] 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 ### 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[], {{5, 3}, {1, 2, 4}}, hl, {x1, x2, x3, x4, x5}] 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] & Use hl = {1, 2, 4, 5} to get  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[], indexlsts, hl, vnames] waGs[.08, .11][#, indexlsts, hl, vnames, ImageSize -> 200,
VertexCoordinates -> GraphEmbedding[wg0]] & /@ wams //
Grid[Partition[#, 3], Dividers -> All] & • 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. Feb 11, 2021 at 22:37
• @TugrulTemel, try VertexReplace[graph, {x1 -> "AGF", x2 -> "OIL", x3 -> "MA1", x4 -> "MA2", x5 -> "EGW"}]?
– kglr
Feb 12, 2021 at 0:34
• Yes, it worked. Thanks a lot. Feb 12, 2021 at 1:17
• When I did wg0 = VertexReplace[waGs[][wams[], 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. Feb 12, 2021 at 1:28
• @Tugrul, I updated waGs[] to allow specifying vertex labels as the optional 4th argument.
– kglr
Feb 12, 2021 at 2:08