2
$\begingroup$

Given:

ClearAll[vl, el, ew, community, g];

vl = {"stel", "segw", "ma7", "str1", "str3", "str2", "swhl", "sest", 
   "min", "sfin", "scst", "ma12", "shot", "ma8", "soth", "srtl", 
   "ma15", "ma6", "str4", "sbus", "ma13"};
el = {"stel" \[DirectedEdge] "segw", "stel" \[DirectedEdge] "ma7", 
   "segw" \[DirectedEdge] "stel", "segw" \[DirectedEdge] "str1", 
   "segw" \[DirectedEdge] "str3", "segw" \[DirectedEdge] "str2", 
   "swhl" \[DirectedEdge] "stel", "swhl" \[DirectedEdge] "sest", 
   "swhl" \[DirectedEdge] "min", "swhl" \[DirectedEdge] "sfin", 
   "scst" \[DirectedEdge] "segw", "scst" \[DirectedEdge] "ma12", 
   "scst" \[DirectedEdge] "shot", "scst" \[DirectedEdge] "ma8", 
   "scst" \[DirectedEdge] "ma7", "scst" \[DirectedEdge] "soth", 
   "srtl" \[DirectedEdge] "segw", "srtl" \[DirectedEdge] "swhl", 
   "srtl" \[DirectedEdge] "ma15", "srtl" \[DirectedEdge] "ma6", 
   "str1" \[DirectedEdge] "segw", "str1" \[DirectedEdge] "str4", 
   "str1" \[DirectedEdge] "sbus", "str1" \[DirectedEdge] "str3", 
   "str1" \[DirectedEdge] "str2", "str1" \[DirectedEdge] "ma7", 
   "sest" \[DirectedEdge] "swhl", "sest" \[DirectedEdge] "srtl", 
   "ma12" \[DirectedEdge] "scst", "ma12" \[DirectedEdge] "ma15", 
   "ma12" \[DirectedEdge] "soth", "shot" \[DirectedEdge] "scst", 
   "str4" \[DirectedEdge] "scst", "str4" \[DirectedEdge] "ma12", 
   "ma15" \[DirectedEdge] "srtl", "ma15" \[DirectedEdge] "shot", 
   "ma15" \[DirectedEdge] "str4", "ma15" \[DirectedEdge] "ma8", 
   "ma15" \[DirectedEdge] "str3", "ma15" \[DirectedEdge] "str2", 
   "ma8" \[DirectedEdge] "str1", "ma8" \[DirectedEdge] "str3", 
   "min" \[DirectedEdge] "sest", "min" \[DirectedEdge] "soth", 
   "sbus" \[DirectedEdge] "sest", "sfin" \[DirectedEdge] "shot", 
   "sfin" \[DirectedEdge] "ma6", "ma6" \[DirectedEdge] "ma8", 
   "ma6" \[DirectedEdge] "min", "ma6" \[DirectedEdge] "ma13", 
   "str3" \[DirectedEdge] "sbus", "str3" \[DirectedEdge] "str2", 
   "ma13" \[DirectedEdge] "str3", "str2" \[DirectedEdge] "str3", 
   "ma7" \[DirectedEdge] "ma13", "soth" \[DirectedEdge] "ma7"};
ew = {0.01313, 0.0139, 0.0131, 0.0188, 0.01145, 0.01842, 
    0.01786, 0.01203, 0.0137, 0.0188, 0.018, 0.01561, 0.01544,  
    0.01767, 0.0174, 0.0133, 0.0184, 0.0126, 0.01724, 0.0126, 
    0.0139, 0.010414`, 0.0169, 0.01498, 0.01736, 0.01832, 
    0.01211, 0.011911, 0.01586`, 0.01863,0.01653, 0.01533, 
    0.0129, 0.0121, 0.01144, 0.014, 0.01109, 0.0172, 0.01267, 
    0.0171, 0.0150, 0.01192, 0.01428, 0.017406, 0.0109, 
    0.017892, 0.01338, 0.017794, 0.01095, 0.0187, 0.0155, 
    0.0142, 0.01422, 0.01125, 0.015559, 0.01788};
community = {{"stel", "segw", "str1", "str3", "str2", "sbus"}, {"ma7",
     "scst", "ma12", "shot", "soth", "str4"}, {"ma8", "srtl", "ma15", 
    "ma6", "ma13"}, {"swhl", "sest", "min", "sfin"}};
g = Graph[vl, el, EdgeWeight -> ew];

HighlightGraph[g, Subgraph[g, #] & /@ community, 
 GraphLayout -> "CircularEmbedding", VertexLabels -> "Name"]

Generates the following circular weighted graph:

enter image description here

I like to have a community graph with the following properties:

  1. Community graph must take into account edge weights (i.e., use weighted community structure);
  2. Community elements should be next to each other as a group and default arrows within communities be kept as they are;
  3. Community area for each community should be of distinct color;
  4. Between community edges should be normalized and communities be linked with a single arrow with thickness measured by the sum of normalized edge weights;
  5. Since the incoming and outgoing arrows between communities may be of different thickness (as measured by normalized edge weights), the respective arrows should be shown separately.

The following chart is an example of what I like to create based on the 5 steps above. Within community links should also be shown as a default format.

enter image description here

$\endgroup$

1 Answer 1

3
$\begingroup$

Start from drawing graph based on community. Compute vertex coordinates:

ccoord = 
  CirclePoints[{1, 0}, 
    21][[Ordering[VertexIndex[g, Flatten[community]]]]];

Draw a highlighted graph with only edges between the same community :

vfunc[{x_, y_}, _, rad_] := 
 With[{ang = ArcTan[x, y]}, 
  Line[{{Cos[ang - rad[[1]]], 
     Sin[ang - rad[[1]]] }, {Cos[ang + rad[[1]]], 
     Sin[ang + rad[[1]]] }}]]

hg = HighlightGraph[g, Subgraph[g, #] & /@ community, 
  VertexCoordinates -> ccoord, 
  VertexLabels -> Placed["Name", "Circular"], 
  EdgeShapeFunction -> (Arrow[
      BSplineCurve[{#[[1]], {0, 0}, #[[-1]]}, 
       SplineWeights -> {1, EuclideanDistance[#[[1]], #[[-1]]]/10, 
         1}]] &), GraphHighlightStyle -> "DehighlightHide", 
  VertexShapeFunction -> vfunc]

enter image description here

create edges between communities with total weights:

m = Length[community];
member = Association[Flatten[Thread /@ Thread[community -> Range[m]]]];
gedges = 
  GroupBy[EdgeList[g], {member[First[#]] &, member[Last[#]] &}, 
   Total[AnnotationValue[{g, #}, EdgeWeight]] &];
{cedges, cweights} = 
  Transpose[
   Flatten[Table[
     If[i != j && NumberQ[gedges[i, j]], {i -> j, gedges[i, j]}, 
      Nothing], {i, m}, {j, m}], 1]];

and draw lines with weight and colors:

astep = 2 Pi/VertexCount[g];
lc = Length /@ community;
cangles = 
  Table[angle, {n, lc}, {angle, 
     astep/2, (n - 1) astep - astep/2, (n - 2) astep/2 }] + 
   astep Most[FoldList[Plus, 0, lc]];
emap = Association@
   Table[i -> 
     AssociationThread[Delete[Range[m], i] -> Range[m - 1]], {i, m} ];

drawLine[Rule[i_, j_], cangles_, emap_, astep_, r_ : .9] :=
 Block[{a, b},
  a = cangles[[i, emap[i, j]]] + astep;
  b = cangles[[j, emap[j, i]]] - astep;
  a = r {Cos[a], Sin[a]};
  b = r {Cos[b], Sin[b]};
  Arrow[BSplineCurve[{a, {0, 0}, b}, 
    SplineWeights -> {1, EuclideanDistance[a, b]/3, 1}]]
  ]

colors = 
  VertexStyle /. 
   AnnotationValue[{hg, {"stel", "ma7", "ma8", "swhl"}}, 
    GraphHighlightStyle];

edges = Riffle[
   Thread[Directive[Arrowheads /@ (3.5 cweights), 
     colors[[cedges[[All, 1]]]], Thickness /@ cweights]], 
   drawLine[#, cangles, emap, astep/3] & /@ cedges];

Put all together with PieChart:

clusterSector[gap_][{{xmin_, xmax_}, y_}, rest___] := 
  Block[{ngap = (xmax - xmin)/2}, 
   If[ngap < gap, ngap = ngap, ngap = gap];
   ChartElementData["Sector"][{{xmin + ngap, xmax - ngap}, y}, rest]];

irad = 9; gap = 0.01;
offset = Pi/VertexCount[g]; PieChart[{6, 6, 5, 4}, 
 SectorOrigin -> {{-(offset*.9), "Counterclockwise"}, irad}, 
 Epilog -> 
  Inset[Show[{hg, Graphics[{Opacity[.8], edges}]}], {0, 0}, {0, 0}, 
   2.2 { irad, irad}], ChartElementFunction -> clusterSector[5 gap], 
 ChartStyle -> (Directive[EdgeForm[#], #] & /@ colors), 
 PerformanceGoal -> "Speed"]

enter image description here

more label scheme:

nmaps = AssociationThread[Rule @@ Transpose[StringSplit[names, ": "]]];
Show[{PieChart[{6, 6, 5, 4}, 
   SectorOrigin -> {{-(offset*.9), "Counterclockwise"}, irad}, 
   Epilog -> 
    Inset[Show[{ Graph[hg, VertexLabels -> _ -> None], 
       Graphics[{Opacity[.8], edges}]}], {0, 0}, {0, 0}, 
     2 { irad, irad}], ChartElementFunction -> clusterSector[5 gap], 
   ChartStyle -> (Directive[EdgeForm[#], #] & /@ colors), 
   PerformanceGoal -> "Speed"], 
  PieChart[
   Thread[Callout[ConstantArray[1, Length[Flatten[community]]], 
     Style[#, Bold, 12] & /@ Flatten[community] /. nmaps]], 
   ChartElementFunction -> ({} &), 
   SectorOrigin -> {{-(1.8 offset), "Counterclockwise"}, irad}, 
   PerformanceGoal -> "Speed"]}, 
 ImagePadding -> {{300, 200}, {50, 20}}, ImageSize -> 1000]

enter image description here

Show[{PieChart[{6, 6, 5, 4}, 
   SectorOrigin -> {{-(offset*.9), "Counterclockwise"}, irad}, 
   Epilog -> 
    Inset[Show[{ Graph[hg, VertexLabels -> _ -> None], 
       Graphics[{Opacity[.8], edges}]}], {0, 0}, {0, 0}, 
     2 { irad, irad}], ChartElementFunction -> clusterSector[5 gap], 
   ChartStyle -> (Directive[EdgeForm[#], #] & /@ colors), 
   PerformanceGoal -> "Speed"], 
  PieChart[ConstantArray[1, Length[Flatten[community]]], 
   ChartElementFunction -> ({} &), 
   ChartLabels -> 
    Placed[Style[#, Bold, 12] & /@ Flatten[community] /. nmaps, 
     "VerticalCallout"], ImagePadding -> {{200, 100}, {0, 0}}, 
   SectorOrigin -> {{-(1.8 offset), "Counterclockwise"}, irad}, 
   PerformanceGoal -> "Speed"]}, 
 ImagePadding -> {{300, 300}, {10, 10}}, ImageSize -> 1000]

enter image description here

$\endgroup$
10
  • $\begingroup$ All is perfect!!! Maybe because of my MMA version 13.1, when I run the code I get the following message drawLine is not a Graphics primitive or directive and hence PieChart does not show the thick colored arrows. Do you have any idea about where the problem is? Again, this is a very nice code. Thanks again. $\endgroup$ Sep 22, 2023 at 21:09
  • $\begingroup$ The thick arrows between communities are normalized edge weights, right? $\endgroup$ Sep 22, 2023 at 21:20
  • $\begingroup$ @TugrulTemel There was typo. It should work now. Thickness are based on the total edge weights between communities. $\endgroup$
    – halmir
    Sep 22, 2023 at 21:27
  • 1
    $\begingroup$ @TugrulTemel maybe.. try to change Epilog to Inset[Show[{PieChart[ Thread[Callout[ConstantArray[1, Length[Flatten[community]]], Flatten[community]]], ChartElementFunction -> ({} &), SectorOrigin -> {{-(1.8 offset), "Counterclockwise"}, .1}, PerformanceGoal -> "Speed"], Graph[hg, VertexLabels -> _ -> None], Graphics[{Opacity[.8], edges}]}], {0, 0}, {0, 0}, 3.1 { irad, irad}] and add ImagePadding -> 30 or more? $\endgroup$
    – halmir
    Sep 25, 2023 at 0:21
  • 1
    $\begingroup$ @TugrulTemel You can rescale cweights to adjust thickness (used inside edges). For length, easiest way could be use set back of Arrow in drawLine function like Arrow[..., {s1, s2}] $\endgroup$
    – halmir
    Sep 26, 2023 at 13:47

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.