5
$\begingroup$

Is it possible to format a Graph object in a similar way to CommunityGraphPlot, but retain it as a Graph? I've been playing with FindGraphCommunities but I'm obviously missing some of the pre-processing that CommunityGraphPlot does.

Ideally I'd like a Graph formatted like CommunityGraphPlot but still easily manipulatible wrt to the right-click options that graph offers.

$\endgroup$
5
$\begingroup$

Let's take the example from the CommunityGraphPlot documentation,

g = ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}]
CommunityGraphPlot@g

Mathematica graphics

At first I thought I would try to replicate what CommunityGraphPlot is doing, using the information from FindGraphCommunities

HighlightGraph[g, Map[Subgraph[g, #] &, FindGraphCommunities@g]]

Mathematica graphics

But that isn't right, we want to separate out the different communities more, to highlight them better. So on to plan 2: let CommunityGraphPlot do the hard work, and take the coordinates from it. If you look at the InputForm for a CommunityGraphPlot you see a bunch of Disk objects, and the are conveniently in the same order as the vertices. So we can feed them to the VertexCoordinates option.

HighlightGraph[
 SetProperty[g,
  {VertexCoordinates -> 
    Cases[CommunityGraphPlot@g, Disk[a__, b_] :> a, Infinity]}],
 Map[Subgraph[g, #] &, FindGraphCommunities@g]]

Mathematica graphics

Now that is really close to what we want, but all those blue lines between communities really make it ugly. So we need to extract the curves between communities and the lines within a community, and create an EdgeShapeFunction from them.

One method is to use Trace to find out what EdgeShapeFunction is being called (For this I'll use a much simpler example that only has 2 curvy lines)

Trace[CommunityGraphPlot@GridGraph[{3, 2}], 
    HoldPattern[EdgeShapeFunction -> _List], TraceInternal -> True] //
    Flatten // DeleteDuplicates // ReleaseHold

Mathematica graphics

This tells us how we need to structure the EdgeShapeFunction. We can extract the "ControlPoints" from the Graphics output of CommunityGraphPlot.

Now we can wrap it all up in a function

communityGraphGraph[g_Graph, options : OptionsPattern[]] := 
 Module[{cgp, gcomm, pts, curves, curveToEdgeFunc}, 
  cgp = Normal@CommunityGraphPlot@g;
  pts = Cases[cgp, Disk[a__, b_] :> a, Infinity];
  curves = curves = Cases[cgp, BezierCurve[__], Infinity][[All, 1]];
  gcomm = FindGraphCommunities@g;
  curveToEdgeFunc[curve_] := 
   First@Select[EdgeList@g, 
      Sort[List @@ #] === 
        Sort@Extract[VertexList@g, 
          Position[pts, 
           First@curve | Last@curve]] &] -> {"GroupBundlingEdge", 
     "ControlPoints" -> curve[[2 ;; -2]], "Opacity" -> Automatic};
  HighlightGraph[
   SetProperty[
    g, {VertexCoordinates -> pts, 
     EdgeShapeFunction -> (curveToEdgeFunc /@ curves)}],
   Map[Subgraph[g, #] &, gcomm], options
   ]
  ]

Here is what it looks like for the graph above,

communityGraphGraph@
 ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}]

Mathematica graphics

One could go a step further and add the circles around the communities by using an Epilog option, and the head would still be Graph. Personally I like the look without the circles, where the edges within a community are colored alike.

Compare the output of this function with the built-in that we are trying to emulate

{communityGraphGraph[GridGraph[{7, 7}], ImageSize -> 500, 
  VertexLabels -> "Name"],
 CommunityGraphPlot[GridGraph[{7, 7}], ImageSize -> 500, 
  VertexLabels -> "Name"]}
Head /@ %

enter image description here

Here is another example from the documentation,

communityGraphGraph[
 ExampleData[{"NetworkGraph", "ZacharyKarateClub"}], ImageSize -> 700,
  VertexShapeFunction -> "Star"]

Mathematica graphics

If you can find a graph that breaks this function, please let me know.

Addendum

Another way to write the function would be to just extract the EdgeShapeFunction directly from the Trace output. This version is a bit shorter, and is pasted here.

$\endgroup$
  • $\begingroup$ Splendid thank you! $\endgroup$ – Gordon Coale May 12 '16 at 21:32
  • $\begingroup$ For that case, it works to just use communityGraphGraph[ ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}], VertexShapeFunction -> "Star"]. $\endgroup$ – Jason B. Jun 20 '18 at 15:08
2
$\begingroup$

Extracting the Graph object

An alternative way of using Trace to extract the Graph object and vertex coordinates:

ClearAll[communityGraphF]
communityGraphF = ReleaseHold[First[Flatten[Trace[CommunityGraphPlot[#, ##2],
  GraphComputation`GraphDrawing[gr_, vc_, __] :> SetProperty[gr, {vc, Options[#]}], 
 TraceInternal -> True]]]] &;

Examples:

zkc = ExampleData[{"NetworkGraph", "ZacharyKarateClub"}];
Row[{CommunityGraphPlot[zkc, ImageSize -> 500], communityGraphF[zkc, ImageSize -> 500]}]

enter image description here

dsn = ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}];
Row[Labeled[ReleaseHold[#[dsn, ImageSize -> 600]], Style[#, 20, "Panel"], Top] & /@ 
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphF]}]

enter image description here

Highlighting within-community edges

ClearAll[communityGraphF2, eS]
eS[g_] := Module[{ghS = PropertyValue[{g, #}, GraphHighlightStyle] &}, 
  If[SameQ[ghS[#], ghS[#2]], VertexStyle /. ghS[#], Gray]] &;

communityGraphF2 = ReleaseHold[First[Flatten[Trace[CommunityGraphPlot[#, ##2], 
  GraphComputation`GraphDrawing[gr_, vc_, __] :> SetProperty[gr, {vc, Options[#], 
   EdgeStyle -> {UndirectedEdge[u_, v_] :> eS[gr][u, v]}}], TraceInternal -> True]]]] &;

Examples:

Row[Labeled[ReleaseHold[#[zkc, ImageSize -> 500]], Style[#, 20, "Panel"], Top] & /@ 
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphF2]}]

enter image description here

Row[Labeled[ReleaseHold[#[dsn, ImageSize -> 500]], Style[#, 20, "Panel"], Top] & /@ 
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphF2]}]

enter image description here

Extracting the blobs and the labels

To get the blobs and labels we need a few more lines:

communityGraphFwBlobs = Module[{blobsandlabels = 
   DeleteDuplicates[ReleaseHold[Flatten@Trace[CommunityGraphPlot[##], 
    _[GraphComputation`GraphCommunitiesPlotDump`blobsgraphics |
      GraphComputation`GraphCommunitiesPlotDump`labelgraphics, b_] :> b, 
   TraceInternal -> True]] /. {{} -> Sequence[], Graphics[x_, ___] :> x }]}, 
  ReleaseHold[First[Flatten[Trace[CommunityGraphPlot[#, ##2], 
    GraphComputation`GraphDrawing[gr_, vc_, __] :> 
     SetProperty[gr, {vc, Options[#], Prolog -> blobsandlabels}], 
   TraceInternal -> True]]]]] &;

Examples:

opts = Sequence[VertexLabels -> "Name", CommunityRegionStyle -> 63, 
   CommunityLabels -> (Style[#, 18] & /@ {"one", "two", "three"}), 
   BaseStyle -> FaceForm[Opacity[.5]], ImagePadding -> 15, ImageSize -> 500];


Row[Labeled[ReleaseHold@#[zkc, opts], Style[#, 20, "Panel"], Top] & /@ 
  {HoldForm[CommunityGraphPlot], HoldForm[communityGraphFwBlobs]}]

enter image description here

Row[Labeled[ReleaseHold@#[dsn, 
   CommunityLabels -> (Style[#, 18] & /@ {"one", "two", "three", "four"}), 
   ImageSize -> 600, opts], Style[#, 20, "Panel"], Top] & /@ 
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphFwBlobs]}]

enter image description here

With an exogenously given community structure as the second argument:

Row[Labeled[ReleaseHold[#[zkc, Partition[VertexList[zkc], 10, 10, 1, {}], opts]], 
  Style[#, 20, "Panel"], Top] & /@
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphFwBlobs]}]

enter image description here

Input graph may have non-default VertexShapeFunction:

zkc2 = SetProperty[zkc, {VertexSize -> 1.5, VertexLabels -> Placed["Name", Center], 
  VertexLabelStyle -> Directive[16, White, Bold], 
  VertexShapeFunction -> "ConcaveHexagon"}];

Row[Labeled[ReleaseHold@#[zkc2, 
  CommunityRegionStyle -> (Opacity[.3, #] & /@ ColorData[63, "ColorList"][[;; 3]]),
  ImageSize -> 500], Style[#, 20, "Panel"], Top] & /@ 
 {HoldForm[CommunityGraphPlot], HoldForm[communityGraphFwBlobs]}]

enter image description here

$\endgroup$

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.