1
$\begingroup$

Given:

CommunityGraphPlot[
  ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}]]

I like to identify:

  1. The edges between each pair of communities;
  2. In the context of a weighted network, find out the weights associated with the edges in (1); and
  3. Combining all the communities in a single weighted adjacency matrix in which the edge weights between the communities are set to zero.

UPDATE: Please see the example weighted graph to be used:

ClearAll[vn, select, mat, wam, wag, comm];
SeedRandom[2];
vn = Table[Subscript[v, i], {i, 20}];
select[matrix_, lB_, uB_] := 
   matrix*Map[Boole[lB <= # <= uB] &, matrix,{-1}];
mat = RandomReal[{}, {20, 20}];
wam = select[mat, .2, .3] /. {0.->\Infinity]};
wag = WeightedAdjacencyGraph[vn, wam];
comm = CommunityGraphPlot[wag, VertexLabels->"Name"]
$\endgroup$
2
  • 3
    $\begingroup$ can you post an example of a weighted network? $\endgroup$
    – kglr
    Feb 6, 2021 at 15:49
  • $\begingroup$ @kglr: Yes, of course. Please see the update of the question. $\endgroup$ Feb 6, 2021 at 16:24

1 Answer 1

2
$\begingroup$
dsn = ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}];

1. The edges between each pair of communities:

ClearAll[cToCedges, edgesBetweenCommunities]
cToCedges = Module[{vToC = Association[
   Join @@ MapIndexed[Thread[# -> #2[[1]]] &]@ FindGraphCommunities[#]]},
    KeySort@GroupBy[EdgeList@#, Sort[vToC /@ VertexList[{#}]] &]] &;

edgesBetweenCommunities = KeySelect[Unequal @@ # &]@*cToCedges;

cToCedges @ dsn

enter image description here

edgesBetweenCommunities @ dsn

enter image description here

CommunityGraphPlot[HighlightGraph[dsn, edgesBetweenCommunities[dsn][{1, 3}], 
  GraphHighlightStyle -> "Thick"], CommunityLabels -> Range[4]]

enter image description here

2. The weights associated with the edges

dsn2 = SetProperty[dsn, EdgeWeight -> RandomInteger[5, EdgeCount[dsn]]];

edgesBetweenCommunities @ dsn2

enter image description here

CommunityGraphPlot[HighlightGraph[dsn2, edgesBetweenCommunities[dsn2][{1, 3}], 
  GraphHighlightStyle -> "Thick"], CommunityLabels -> Range[4]]

enter image description here

KeyValueMap[# -> (Map[# ->  PropertyValue[{dsn2, #}, EdgeWeight] &]@#2) &] @
 edgesBetweenCommunities[dsn2]

enter image description here

Using wag from OP:

MapAt[Highlighted, cToCedges @ wag, {Key[{2, 3}]}]

enter image description here

KeyValueMap[# -> (Map[# -> PropertyValue[{wag, #}, EdgeWeight] &]@#2) &]@
 edgesBetweenCommunities[wag]

enter image description here

CommunityGraphPlot[HighlightGraph[wag, edgesBetweenCommunities[wag][{2, 3}], 
  GraphHighlightStyle -> "Thick"], VertexLabels -> "Name", 
 CommunityLabels -> Range[Length @ FindGraphCommunities @ wag]]

enter image description here

3. Set the edge weights between the communities to zero

This can be done in several ways:

betweenEdges = Flatten[Values @ edgesBetweenCommunities @ wag]; 

i. Get the positions of vertices connecting different communities and set the values corresponding to those indices to 0 using MapAt:

positions = Flatten /@ List @@@ (betweenEdges /. PositionIndex[vn]);

wam1 = WeightedAdjacencyMatrix[wag];

MatrixForm @ MapAt[Highlighted, Round[#, .1] &@ wam1, positions]

enter image description here

wam2 = MapAt[0 &, wam1, positions];

MatrixForm @ MapAt[Highlighted, Round[#, .1] &@wam2, positions]

enter image description here

ii. Use SetProperty to set the edge weights to 0 for edges in the list betweenEdges:

wam3 = WeightedAdjacencyMatrix @
   Fold[SetProperty[{#, #2}, EdgeWeight -> 0] &, wag, betweenEdges];

wam2 == wam3

True

Note: If the goal is to get the edge list betweenEdges (that is, if we are not interested in edges connecting particular community pairs), it can be done more directly:

betweenEdges2 = EdgeList[GraphDifference[wag, 
    GraphUnion @@ (Subgraph[wag, #] & /@ FindGraphCommunities[wag])]];


Sort @ betweenEdges2 == Sort @ betweenEdges
 True
$\endgroup$
8
  • $\begingroup$ Your answers are not only very clear answers but also valuable material for a teaching tutorial. I learned a lot from your earlier posts. Thank you. $\endgroup$ Feb 7, 2021 at 0:59
  • $\begingroup$ @TugrulTemel, thank you for the kind words and the accept. $\endgroup$
    – kglr
    Feb 7, 2021 at 1:00
  • 1
    $\begingroup$ @TugrulTemel, does wam3 = WeightedAdjacencyMatrix @ Fold[SetProperty[{#, #2}, EdgeWeight -> -0.4*PropertyValue[{#,#2}, EdgeWeight]] &, wag, betweenEdges] give what you need? $\endgroup$
    – kglr
    Mar 2, 2021 at 0:36
  • 1
    $\begingroup$ @TugrulTemel, try if MapAt[- .4 #&, wam1, positions] (where positions = Flatten /@ List @@@ (betweenEdges /. PositionIndex[vn]);) is any faster. $\endgroup$
    – kglr
    Mar 2, 2021 at 6:36
  • 1
    $\begingroup$ Yes, it is quite fast compared to what I have. At least, my computer generates a result without freezing. Thank you. $\endgroup$ Mar 2, 2021 at 22:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.