Replicate CommunityGraphPlot as a Graph

Question

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.

Answer 1

Let's take the example from the CommunityGraphPlot documentation,

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

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]]

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]]

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

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

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 /@ %

Here is another example from the documentation,

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

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.

Answer 2

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]}]

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

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]}]

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

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]}]

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

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]}]

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]}]