3
$\begingroup$

Given the following code:

ClearAll[names, vl, el, ew, community, vName, vRule, g, evc];
names = {
   "agr: Agriculture, hunting, forestry, fishing", 
   "min: Mining and quarrying", "ma1: Food, beverages, tobacco", 
   "ma2: Textiles, textile products", 
   "ma3:   Leather, leather products, footwear", 
   "ma4: Wood & products of wood and cork", 
   "ma5: Pulp, paper, paper products, printing, publishing", 
   "ma6: Coke, refined petroleum, nuclear fuel", 
   "ma7: Chemicals & chemical products", 
   "ma8: Rubber-plastics products", 
   "ma9: Other non-metallic mineral products", 
   "ma10: Manufacture of basic metals", 
   "ma11: Machinery-equipment n.e.c", "ma12: Electrical  
   equipment", "ma13: Transport equipment", "ma14: 
   Manufacturing, nec; recycling", "segw: Electricity, gas,   
   water supply", "scst: Construction", "ma15: Sale-maintenance; 
   repair-install. of mach. equip.", "swhl: Wholesale trade, 
   except motor vehicles", 
   "srtl: Retail trade, except of motor vehicles", 
   "shot: Hotels & restaurants", "str1: Inland transport", 
   "str2: Water transport", "str3: Air transport", 
   "str4: Other supporting-transport act. of travel agencies", 
   "stel: Post & telecommunications", 
   "sfin: Financial intermediation", "sest: Real estate activities", "sbus: Renting of M&Eq and other business activities", 
   "sadm: Public adm.-defence;compulsory social security", 
   "sedu: Education", "shlt: Human health-social work", 
   "soth: Other community, social & personal services"
   };

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"}};

vName = Lookup[Flatten@community]@
   MapApply[Rule]@StringSplit[names, ": "];
vRule = Thread[Flatten[community] -> vName];
g = Graph[vl, el, EdgeWeight -> ew];

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

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 -> "Circle"
];

lp = ListPlot[Callout @@@ 
   Transpose[{GraphEmbedding[hg], VertexList[hg] /. vRule}], 
   Axes -> False, PlotStyle -> None];

Show[hg, lp]

Relevant posts in the MMA repository are

from https://mathematica.stackexchange.com/a/290654/60365 by @halmir

from https://mathematica.stackexchange.com/a/140885/60365 by @kglr

The directed graph produced is: enter image description here

I want to produce the directed graph with the vertex long names, not with vertex short names such as stel. As you can see from the following graph, Callout is not working properly.

I like to use Callout with long vertex names placed on the right and left sides of the graph vertically.

Improve this question
$\endgroup$

4 Answers 4

Reset to default
6
$\begingroup$

enter image description here

First, two functions to be used as option settings for EdgeShapeFunction and VertexShapeFunction:

ClearAll[vShF, poincareESF, circleToCoords]

circleToCoords[Circle[ctr_, rad_, {a1_, a2_}]] := 
  Module[{al = Subdivide[a1, a2, 50]}, (ctr + rad {Cos[#1], Sin[#1]} &) /@ al];

GraphComputation`GraphPropertyChart;

poincareESF = ReplaceAll[c_Circle :> Arrow @ circleToCoords[c]] @
  GraphComputation`GraphChartDump`geo[0.99 First@#, 0.99 Last@#, "segment"]&;


vShF[assoc_Association, lbls_Association, ps_ : 5, fs_ : .06, ls_ : 250] := 
  Module[{off = If[-(π/2) < ArcTan @@ # < π/2, -1, 1]}, {assoc[#2], 
     Text[Style[Pane[lbls @ #2, ImageSize -> {ls, Automatic}, 
        Alignment -> off /. {1 -> Right, -1 -> Left}], 
       FontSize -> Scaled[fs]], #, { 1.1 off, Center}, 
      ArcTan[#] (-off)], AbsolutePointSize[ps], Point[#]}] &;

We use a slightly modified version of vName from OP:

vName = Lookup[Flatten @ community] @ MapApply[Rule] @
  Map[StringTrim @* StringDelete["\n" | "  "]] @ StringSplit[names, ": "];

Use community and el to get a vertex list and list of intra-community edges:

sortedvl = Join @@ community;

internalCommunityEdges = Flatten[EdgeList[Subgraph[g, #]] & /@ community];

Define two associations for labeling and styling:

lblAssoc = Association @ Thread[Flatten[community] -> vName];

automaticHighlightColors = 
    GraphComputation`GraphInformationDump`$AutomaticColorList;

clrAssoc = Association @ Flatten @ Map[Thread][
  Thread[community -> Take[automaticHighlightColors, Length @ community]]];


Graph[sortedvl, internalCommunityEdges, 
 GraphLayout -> {"CircularEmbedding", "OptimalOrder" -> False}, 
 EdgeShapeFunction -> poincareESF, 
 VertexShapeFunction -> vShF[clrAssoc, lblAssoc],
 EdgeStyle -> 
    {e_ :> Directive[Arrowheads[{{Small, .75}}], clrAssoc[e[[1]]]]},
 ImageSize -> Large, 
 ImagePadding -> 180]

picture above

Use vShF[clrAssoc, lblAssoc, 5, .03, 160], Arrowheads[{{Medium, .75}}] and ImageSize -> 800 to get

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ How can I plot the between community edges on top of the above figure? @halmir developed this code to find the btw-community edge 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] ]. $\endgroup$
    – Tugrul Temel
    Commented Feb 16 at 19:36
  • $\begingroup$ Something happened to MSE forum and I cannot ask questions on the forum. This is my last resort! $\endgroup$
    – Tugrul Temel
    Commented Feb 16 at 19:37
4
$\begingroup$

1.

Just use VertexLabels -> {v_ :> Placed[v /. vRule, "Circular"]} and a large value for ImageSize:

HighlightGraph[g, Subgraph[g, #] & /@ community, 
 VertexCoordinates -> ccoord, 
 VertexLabels -> {v_ :> Placed[v /. vRule, "Circular"]}, 
 EdgeShapeFunction -> (Arrow[
     BSplineCurve[{#[[1]], {0, 0}, #[[-1]]}, 
      SplineWeights -> {1, EuclideanDistance[#[[1]], #[[-1]]]/10, 
        1}]] &), GraphHighlightStyle -> "DehighlightHide", 
 VertexShapeFunction -> "Circle", 
 ImageSize -> 1000]

enter image description here

2.

Using ListPlot and Callout:

lp = ListPlot[Callout[##, If[#[[1]] <= 0, Before, After], 
      "LabelVisibility" -> All] & @@@ 
    Transpose[{GraphEmbedding[hg], VertexList[hg] /. vRule}], 
   Axes -> False, PlotStyle -> None];

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

Show[hg, lp]

enter image description here

Improve this answer
$\endgroup$
2
$\begingroup$ 
nmaps = AssociationThread[Rule @@ Transpose[StringSplit[names, ": "]]];
pchart = 
  PieChart[
   Thread[Callout[ConstantArray[1, Length[Flatten[community]]], 
     Style[#, Bold, 12] & /@ Flatten[community] /. nmaps]], 
   ChartElementFunction -> ({} &), 
   SectorOrigin -> {{-(1.8 \[Pi]/34), "Counterclockwise"}, .01}, 
   PerformanceGoal -> "Speed"];
Show[Graph[hg, VertexLabels -> {_ -> None}], pchart, ImageSize -> 800]

enter image description here

Improve this answer
$\endgroup$
2
$\begingroup$ 
sortedvl = Join @@ community;

internalCommunityEdges = Flatten[EdgeList[Subgraph[g, #]] & /@ community];

lblAssoc = Association@Thread[Flatten[community] -> vName];

automaticHighlightColors = 
  GraphComputation`GraphInformationDump`$AutomaticColorList;

clrAssoc = Association @ Flatten @ Map[Thread][
  Thread[community -> Take[automaticHighlightColors, Length@community]]];

g0 = Graph[sortedvl, internalCommunityEdges, 
   GraphLayout -> {"CircularEmbedding", "OptimalOrder" -> False}];

GraphComputation`GraphPropertyChart

GraphPropertyChart combines a graph with a good-looking layout and edge shapes and a pie-chart based on desired vertex properties. It takes both PieChart and Graph options.

 GraphComputation`GraphPropertyChart[g0, 
  Automatic -> Table[1, Length @ sortedvl],  
  ChartStyle -> Values @ clrAssoc,
  VertexStyle -> Opacity[0],
  EdgeStyle -> {e_ :> clrAssoc[First@e]},
  ChartLabels -> Placed[Values@lblAssoc, "VerticalCallout"],
  ImageSize -> 900, 
  ImagePadding -> {{200, 200}, {Automatic, Automatic}}] //
    ReplaceAll[{Arrowheads[__] :> Arrowheads[{{Medium, .8}}], 
       False -> True, Thickness[_] :> AbsoluteThickness[1]}]

enter image description here

Add the option

  ChartElementFunction -> 
    (Disk[Mean[#[[2]]] {Cos[Mean @ #[[1]]], Sin[Mean @ #[[1]]]}, 
      Pi Abs[Subtract @@ #[[1]]]/3] &)

to get

enter image description here

Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ Thanks for the codes! In the last two figures above, it might be better to use Arrow Heads along the edges so that one can see the actual direction of the edges. Currently, it is a bit difficult to differentiate the edge directions. You do not need to revise the codes, you may just tell me where to change in the codes to get the desired effects. $\endgroup$
    – Tugrul Temel
    Commented Sep 25, 2023 at 20:16
  • 1
    $\begingroup$ excellent point. Please see the updated post. $\endgroup$
    – kglr
    Commented Sep 25, 2023 at 20:36
  • $\begingroup$ Thank you for your prompt response! $\endgroup$
    – Tugrul Temel
    Commented Sep 25, 2023 at 20:45

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.