3
$\begingroup$

I request an efficient Code for the following computations. The computations do exactly what I intend to achieve (I assume?), however, the code looks poor and inefficient, and I cannot go on with higher order layers because of my poor programming skills. Therefore, for illustrative purposes, I could compute two layers only.

Here is a brief description of how to identify cascades of layers of one-edge neighbors of a given sector i in a directed graph.

  1. Layer(i,1) denotes layer 1 of sector i, which is defined by one-edge neighbors of i (denoted by N(i)={sectors(i), binary links(i)});
  2. Suppose that sectors j, k, l are elements of the set sectors(i) in N(i), for each sector j, k, l, find their one-edge neighbors: N(j), N(k), N(l);
  3. Subtract binary links(i) from the Union of binary links(j), binary links(k), binary links(l). The remaining list of binary links and the associated sectors define Layer(i, 2);
  4. To obtain Layer(i,3), repeat the same procedure using N(j), N(k), N(l);
  5. Identification of layers should stop when all the sectors in the given start network are exhausted.

Here is the code implementing the above procedure for two layers only:

el = {"EGW" \[DirectedEdge] "MA2", "EGW" \[DirectedEdge] "HLT",   "EGW" \[DirectedEdge] "AGF", "EGW" \[DirectedEdge] "WHS", "EGW" \[DirectedEdge] "TSC", "EGW" \[DirectedEdge] "CST", "HLT" \[DirectedEdge] "MA2", "HLT" \[DirectedEdge] "EGW", "HLT" \[DirectedEdge] "TSC", "HLT" \[DirectedEdge] "CST", "AGF" \[DirectedEdge] "EGW", "AGF" \[DirectedEdge] "HLT", "AGF" \[DirectedEdge] "WHS", "AGF" \[DirectedEdge] "TSC", "CO12" \[DirectedEdge] "HLT", "CO12" \[DirectedEdge] "AGF", "CO12" \[DirectedEdge] "WHS", "FIN" \[DirectedEdge] "AGF", "WHS" \[DirectedEdge] "CO12", "TSC" \[DirectedEdge] "CO12", "TSC" \[DirectedEdge] "FIN", "CST" \[DirectedEdge] "FIN"};

vl = {"MA2", "EGW", "HLT", "AGF", "CO12", "FIN", "WHS", "TSC", "CST"};

ewl = {0.021, 0.019, 0.017, 0.026, 0.023, 0.026, 0.015, 0.011, 0.015, 
 0.013, 0.017, 0.015, 0.026, 0.016, 0.025, 0.018, 0.018, 0.017, 
 0.016, 0.012, 0.021, 0.014};

wGraph = Thread[{el, ewl}];

gr = Graph[el, VertexLabels -> "Name", PlotLabel -> "Given a graph", 
 ImageSize -> 250];
HighlightGraph[gr, Subgraph[gr,layer1 = NeighborhoodGraph[gr, "MA2", PlotLabel -> "Layer 1"]], ImageSize -> 250];
el1 = EdgeList[layer1];
vl1 = VertexList[layer1];

HighlightGraph[gr,Subgraph[gr, layer21 = NeighborhoodGraph[gr, "EGW"]]];
HighlightGraph[gr,Subgraph[gr, layer22 = NeighborhoodGraph[gr, "HLT"]]];
el21 = EdgeList[layer21];
vl21 = VertexList[layer21];
el22 = EdgeList[layer22];
vl22 = VertexList[layer22];

el21Uel22 = Union[el21, el22];
layer2 = Graph[Complement[el21Uel22, el1], VertexLabels -> "Name", 
 PlotLabel -> "Layer 2", ImageSize -> 250];

Row[{gr, Spacer[20], layer1, Spacer[20], layer2}]

Here is what it produces:

enter image description here

I would be grateful if the efficient Code derives layers

  • as a sequence of Subgraphs like I did above to allow for the reconstruction of the starting graph by sequentially clipping individual layers (Subgraphs) to each other.
  • show the final layered graph as a CommunityGraph.
$\endgroup$

1 Answer 1

3
$\begingroup$

1. Getting the layers

ClearAll[nextLayer, layersList]
nextLayer[g_] := Complement[
  EdgeList @ Apply[GraphUnion] @ Map[NeighborhoodGraph[g, #] &] @ VertexList[#], 
  EdgeList @ #] &;

layersList[g_, startingVertex_, steps_] := 
 Rest @ NestList[nextLayer[g], Graph[{startingVertex}, {}], steps]

Examples:

Transpose[{Range[5], layersList[gr, "MA2", 5]}] // Grid

enter image description here

MapIndexed[
   Graph[#, VertexLabels -> "Name", ImageSize -> 200, 
     PlotLabel -> Row[{"Layer " , #2[[1]]}]] &] @ 
  layersList[gr, "MA2", 5] // Row[#, Spacer[10]] &

enter image description here

Alternatively, use NestWhileList to get a cycle-free list:

ClearAll[allLayers]
allLayers[g_, startingVertex_] := 
 Rest @ NestWhileList[nextLayer[g], Graph[{startingVertex}, {}], 
   DuplicateFreeQ @* List, All, Infinity, -1]

Examples:

MapIndexed[{#2[[1]], #} &]@allLayers[gr, "MA2"] // Grid

enter image description here

MapIndexed[
   Graph[#, VertexLabels -> "Name", ImageSize -> 300, 
     PlotLabel -> Row[{"Layer " , #2[[1]]}]] &] @ allLayers[gr, "MA2"] //
  Row[#, Spacer[10]] &

enter image description here

2. CommunityGraphPlot

Map VertexList on allLayers[gr, "MA2"] to get a community structure:

communitystructure = VertexList /@ allLayers[gr, "MA2"]
{{"EGW", "HLT", "MA2"},
 {"AGF", "EGW", "HLT", "TSC", "WHS", "CO12", "CST"},
 {"CO12", "WHS", "CST", "FIN", "EGW", "HLT", "MA2", "AGF",  "TSC"}}

Use communitystructure in the second argument of CommunityGraphPlot:

CommunityGraphPlot[EdgeList@gr, communitystructure, 
 ImageSize -> Large, VertexLabels -> Placed["Name", Center], 
 VertexSize -> Large, 
 CommunityRegionStyle -> (Opacity[.3, #] & /@ {Red, Green, Blue}), 
 PlotLegends -> SwatchLegend[
   Opacity[.3, #] & /@ {Red, Green, Blue},
  {"Layer 1", "Layer 2", "Layer 3"},
  LegendMarkerSize -> Medium, "Spacings" -> {1, 1}]]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thanks for this very efficient code. It seems that the code is doing a slightly different computation than I was expecting. (1) The layers need to be mutually exclusive (in edges but not in vertices), (2) previously computed layers should not show up in latter layers. These conditions are violated in the code. I tried the code with different examples, but again these two conditions are not satisfied. One reason is that somewhere in the code, previously found edges are not subtracted from the latter layers. $\endgroup$ Feb 3, 2023 at 12:58

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.