15
$\begingroup$

Consider the following problem: Assume you have a large list of directed edges, that constitute a large graph. I would like to provide an initial subset of vertices and I need to know which additional vertices I need to select in order to

  1. make sure that the resulting (sub)-graph is connected
  2. make sure that I don't have sink/source vertices, i.e. all vertices have at least one incoming and one outgoing edge.
  3. minimize the number of additional vertices

I don't have a working code (at least not for V8+). But assume the following directed edges:

ex = {"9" -> "7", "4" -> "6", "1" -> "9", "3" -> "5", "10" -> "8", 
   "5" -> "2", "2" -> "5", "9" -> "3", "3" -> "1", "7" -> "9", 
   "8" -> "6", "3" -> "10", "2" -> "1", "7" -> "4", "1" -> "4", 
   "2" -> "7", "5" -> "6", "7" -> "2"};

gr=Graph[ex, VertexLabels -> "Name", ImagePadding -> 20]

enter image description here

Say, we initially choose vertices "1" and "3" and "7", then the subgraph has source/sinks:

Subgraph[gr, {"3", "1", "7"}, VertexLabels -> "Name", ImagePadding -> 20]

enter image description here

Now, a possible completion of the graph without sinks/sources would be:

sgr=Subgraph[gr, {"3", "1", "9", "7"}, VertexLabels -> "Name", 
 ImagePadding -> 20]

enter image description here

HighlightGraph[gr, sgr]

enter image description here

I understand that this problem might not have a unique solution. Any solution is fine for me. (The upgraded Graph capabilities of V8 are still mostly unexplored area for me, so I apologize for not having a working initial solution. My V7 approach stopped working so I hesitate in postin it here.)

I need to do this for a large set of directed edges (10000+) so performance might be an issue as well.

Edit(new):

Following up on Szabolcs comments & answer the following works very well.

badguys[gr_] := Union[sinks[gr], sources[gr]]
healthyGraph[gr_] := FixedPoint[VertexDelete[#, badguys[#]] &, gr]
completeNetwork::ggraphx = "At least one of the vertices `1` is a sink or source.";
completeNetworkStep[g_?GraphQ, list_] /; 
  And @@ (MemberQ[VertexList[g], #] & /@ list) := Module[{clist},
  (* connect the vertices*)
  clist = connect[g, list];
  (*remove sinks*)
  clist = FixedPoint[step[sinks][g, #] &, clist];
  (*remove sources*)
  clist = FixedPoint[step[sources][g, #] &, clist]]
completeNetwork[g_?GraphQ, list_] /; 
  And @@ (MemberQ[VertexList[g], #] & /@ list) := Module[{hgr},
  (* clean the network from sinks/sources*)
  hgr = healthyGraph[g];
  (* check if list of vertices is still part of the healthy graph*)
  If[
   And @@ (MemberQ[VertexList[hgr], #] & /@ list),
   FixedPoint[completeNetworkStep[hgr, #] &, list],
   Message[completeNetwork::ggraphx, list]; {}]
  ]
ShowCompleteSubgraph[g_?GraphQ, list_] := 
  HighlightGraph[g, Subgraph[g, completeNetwork[g, list]]]

In many instances the algorithm works very good. Some problems remain though. Consider the following setup:

vertices = {30, 43, 57, 1, 75, 24, 74, 94, 62, 47, 51, 89, 95, 87, 5, 
 73, 80, 91, 3, 67, 4, 8, 93, 18, 85, 49, 39, 13, 45, 79, 96, 98, 
 81, 19, 21, 15, 10, 60, 77, 76};
edges = {85 -> 4, 94 -> 95, 45 -> 18, 75 -> 3, 80 -> 30, 15 -> 80, 
  51 -> 21, 15 -> 43, 13 -> 95, 75 -> 91, 4 -> 30, 95 -> 76, 
  94 -> 51, 95 -> 21, 30 -> 45, 81 -> 96, 39 -> 13, 89 -> 1, 76 -> 3,
  96 -> 47, 67 -> 77, 67 -> 10, 4 -> 24, 57 -> 89, 73 -> 95, 
  89 -> 51, 45 -> 80, 21 -> 8, 74 -> 73, 98 -> 96, 4 -> 76, 77 -> 79,
  43 -> 93, 15 -> 19, 3 -> 57, 76 -> 15, 94 -> 24, 45 -> 15, 
  75 -> 89, 73 -> 60, 3 -> 49, 98 -> 10, 1 -> 43, 10 -> 15, 49 -> 5, 
  8 -> 79, 51 -> 10, 60 -> 51, 3 -> 13, 60 -> 43, 96 -> 62, 57 -> 4, 
  45 -> 95, 67 -> 5, 1 -> 4, 98 -> 30, 39 -> 75, 39 -> 18, 89 -> 75, 
  89 -> 15, 43 -> 39, 60 -> 10, 91 -> 39, 85 -> 8, 47 -> 89, 
  57 -> 85, 76 -> 39, 98 -> 95, 51 -> 73, 76 -> 8, 30 -> 49, 
  87 -> 49, 77 -> 93, 80 -> 21, 96 -> 57, 39 -> 76, 39 -> 30, 
  62 -> 91, 94 -> 10, 96 -> 81, 95 -> 75, 62 -> 77, 3 -> 87, 
  43 -> 87, 49 -> 24, 21 -> 87, 94 -> 39, 94 -> 98, 87 -> 89, 
  5 -> 13, 21 -> 67, 47 -> 5, 62 -> 47, 39 -> 47, 91 -> 60, 96 -> 76,
  10 -> 79};
ini1 = {45, 4, 62, 15, 51};
exgr = Graph[edges, VertexLabels -> "Name"];
{{sinks@#, sources@#} &@
  Subgraph[exgr, completeNetwork[exgr, ini1]], ini1, 
  completeNetwork[exgr, ini1]}

{{{}, {96}}, {45, 4, 62, 15, 51}, {1, 4, 15, 21, 30, 43, 45, 47, 51, 57, 62, 76, 87, 89, 96}}

You see that a source vertex (96) remains. The graph looks like

ShowCompleteSubgraph[exgr, completeNetwork[exgr, ini1]]

enter image description here

Apparently, vertex 62 from the initial list has only outgoing edges, except for 96->62. How can we modify the algorithm to open up routes along alternative edges?

Improve this question
$\endgroup$
9
  • $\begingroup$ 1. In your example, it was not really necessary to select 7, just selecting 9 would have been enough. Is this correct? 2. Are you strict on condition 3, or an approximation will do? $\endgroup$
    – Szabolcs
    May 31, 2012 at 13:09
  • $\begingroup$ @Szabolcs True. "7" was not neccessary. 2. No! I am not too strict on the minimization. I just want to prevent the solution to blow up. $\endgroup$
    – Markus Roellig
    May 31, 2012 at 13:16
  • 1
    $\begingroup$ This is unrelated, but I was wondering why the lines are thicker than the default in your figures. Did you set a higher screen resolution? If yes, which is the resolution option that will affect line widths too? Another thing: if you convert the graph plots to graphics by prepending Show (e.g. Show@Graph[...]), then you won't need the ImagePadding workaround to avoid cutting off the vertex names. (I'm still trying to come up with a solution to your question...) $\endgroup$
    – Szabolcs
    May 31, 2012 at 13:32
  • $\begingroup$ @Szabolcs I wasn't aware that the lines are thicker, but I set the screen magnification to 150% at the bottom right of the window. Thanks for the tip with Show@Graph. $\endgroup$
    – Markus Roellig
    May 31, 2012 at 13:35
  • 1
    $\begingroup$ How about using FindShortestPath or related functions? For question 1, break the subgraph into components, then find a shortest path between two components (using an undirected version of gr). Include the path in the subgraph. Repeat until there's only one component in the subgraph. For question 2, find a sink/source, then find a shortest path (in the directed version of gr) to any other vertex of the subgraph. Include the shortest path in the subgraph, then repeat until there are no sinks/sources. It won't minimize the added nodes, but it should work ... $\endgroup$
    – Szabolcs
    May 31, 2012 at 13:50

3 Answers 3

Reset to default
5
$\begingroup$

Let's denote the graph by gr and the initial subset of vertices by v.

Connecting the graph

First, we break the subgraph generated by v into connected components. We select one vertex from the smallest connected component, and another one that is not in it. We find the shortest path in the undirected gr that connects these two, and add all vertices from the shortest path to v. Repeat until the subgraph becomes connected.

smallestComponent[g_Graph] := 
 With[{components = ConnectedComponents@UndirectedGraph[g]},
  Extract[components, Ordering[components, 1]]
 ]

connectStep[gr_, v_] :=
 Module[{sc, rest},
  sc = smallestComponent@Subgraph[gr, v];
  rest = Complement[v, sc];
  If[rest === {},
   v,
   Union[
    FindShortestPath[UndirectedGraph[gr], First[sc], First[rest]],
    v
    ]
   ]
  ]

connect[gr_, v_] := FixedPoint[connectStep[gr, #] &, v]

Usage:

connect[gr, {"1", "3", "7"}]

(* ==> {"1", "3", "7", "9"} *)

Getting rid of sinks and sources

Let's assume that the subgraph is connected.

Take the subgraph, and select one sink from v. Then select any other vertex and find the shortest path between these two in the directed gr, using the sink as starting point. Add all vertices from the shortest path to v. Repeat until there are no sinks in the subgraph.

Sources can be removed in an analogous way, except they need to be end point of the path.

sinks[g_?GraphQ] := Pick[VertexList[g], VertexOutDegree[g], 0]
sources[g_?GraphQ] := Pick[VertexList[g], VertexInDegree[g], 0]

step[sinkOrSource_][gr_, v_] :=
 Module[{ss, s, t},
  ss = sinkOrSource[Subgraph[gr, v]];
  If[ss === {},
   v,

   s = First[ss];
   t = First@DeleteCases[v, s];
   If[sinkOrSource == source, {s,t} = {t,s}];
   Union[v, FindShortestPath[gr, s, t]]
   ]
  ]

FixedPoint[step[sink][gr, #]&, {"1", "3"}]

(* ==> {"1", "3", "9"} *)
Improve this answer
$\endgroup$
3
  • $\begingroup$ neat! Give me some time to test it with different networks. $\endgroup$
    – Markus Roellig
    May 31, 2012 at 15:27
  • $\begingroup$ There are cases where the algorithm runs in circles. Consider: FixedPoint[step[sources][gr, #] &, {"5", "3", "2"}]. "3" is a source term, and remains so. $\endgroup$
    – Markus Roellig
    May 31, 2012 at 16:26
  • $\begingroup$ @MarkusRoellig Sorry, my function is misleading because it seems that you can simply switch sinks to sources. It is also necessary to exchange s and t in FindShortestPath. I made a quick edit to fix it (a hack,r eally) but don't have time to test now... $\endgroup$
    – Szabolcs
    May 31, 2012 at 16:30
4
$\begingroup$

Most of the work can be done much simpler than Szabolcs' answer.

1: Identify and get rid of sinks/sources and useless vertices in a single step

You can weed out all sinks/sources and vertices that will only lead to sinks/sources easily as follows:

{deadVtx, possibleVtx} = GatherBy[ConnectedComponents[gr], Length[#]==1 &];

You can see for yourself that any vertex in deadVtx will not lead you anywhere: enter image description here

2: Use ConnectedGraphQ to check for connectivity

Given an initial vertex list initVtx, you can:

  1. use the above two vertex lists and MemberQ to check if the initial list contains any vertex from the deadVtx list and issue an error and stop if it does.

  2. check if it is already connected with

    ConnectedGraphQ[Subgraph[gr, initVtx]]

  3. add vertices only from the possibleVtx list if it is not already connected.

3: Get components that are immediately connected using VertexComponent:

If it is not already connected, instead of adding an arbitrary, possibly distant vertex, you can pick one that is only 1 connection away from the existing vertices with:

Complement[VertexComponent[sgr, initVtx, 1], initVtx]

I think the above can be worked into your vertex folding routine, and so I'm not doing that part.

Improve this answer
$\endgroup$
2
  • $\begingroup$ VertexComponent[gr, initVtx, 1] will add every vertex that's distance one from any vertex in initVtx. This might be a lot more than what's necessary to add to the set. $\endgroup$
    – Szabolcs
    Jun 2, 2012 at 10:41
  • $\begingroup$ @Szabolcs No, I didn't suggest adding them all... I said pick one from that smaller list. You still have to do a little search, but with a smaller set. $\endgroup$
    – rm -rf ♦
    Jun 2, 2012 at 15:09
2
$\begingroup$

We can use GraphComputation`SourceVertexList and GraphComputation`SinkVertexList to get the source and sink vertices and VertexDelete them using the function:

vdF = VertexDelete[#, Union[GraphComputation`SinkVertexList[#], 
     GraphComputation`SourceVertexList[#]]] &;

A FixedPoint of the function vdF will have no source or sink vertices.

Examples:

Row[{g1 = RandomGraph[{15, 20}, DirectedEdges -> True, 
    VertexLabels -> "Name", ImagePadding -> 20, ImageSize -> 300], 
  fp = FixedPoint[vdF, g1], HighlightGraph[g1, EdgeList[fp]]}]

enter image description here

ex = {"9" -> "7", "4" -> "6", "1" -> "9", "3" -> "5", "10" -> "8", 
 "5" -> "2", "2" -> "5", "9" -> "3", "3" -> "1", "7" -> "9", 
 "8" -> "6", "3" -> "10", "2" -> "1", "7" -> "4", "1" -> "4", 
 "2" -> "7", "5" -> "6", "7" -> "2"};

gr = Graph[ex, VertexLabels -> "Name", ImagePadding -> 20, ImageSize -> 300];
Row[{gr, fp = FixedPoint[vdF, gr], HighlightGraph[gr, EdgeList[fp]]}]

enter image description here

vertices = {30, 43, 57, 1, 75, 24, 74, 94, 62, 47, 51, 89, 95, 87, 5, 
   73, 80, 91, 3, 67, 4, 8, 93, 18, 85, 49, 39, 13, 45, 79, 96, 98, 
   81, 19, 21, 15, 10, 60, 77, 76};
edges = {85 -> 4, 94 -> 95, 45 -> 18, 75 -> 3, 80 -> 30, 15 -> 80, 
   51 -> 21, 15 -> 43, 13 -> 95, 75 -> 91, 4 -> 30, 95 -> 76, 
   94 -> 51, 95 -> 21, 30 -> 45, 81 -> 96, 39 -> 13, 89 -> 1, 76 -> 3,
    96 -> 47, 67 -> 77, 67 -> 10, 4 -> 24, 57 -> 89, 73 -> 95, 
   89 -> 51, 45 -> 80, 21 -> 8, 74 -> 73, 98 -> 96, 4 -> 76, 77 -> 79,
    43 -> 93, 15 -> 19, 3 -> 57, 76 -> 15, 94 -> 24, 45 -> 15, 
   75 -> 89, 73 -> 60, 3 -> 49, 98 -> 10, 1 -> 43, 10 -> 15, 49 -> 5, 
   8 -> 79, 51 -> 10, 60 -> 51, 3 -> 13, 60 -> 43, 96 -> 62, 57 -> 4, 
   45 -> 95, 67 -> 5, 1 -> 4, 98 -> 30, 39 -> 75, 39 -> 18, 89 -> 75, 
   89 -> 15, 43 -> 39, 60 -> 10, 91 -> 39, 85 -> 8, 47 -> 89, 
   57 -> 85, 76 -> 39, 98 -> 95, 51 -> 73, 76 -> 8, 30 -> 49, 
   87 -> 49, 77 -> 93, 80 -> 21, 96 -> 57, 39 -> 76, 39 -> 30, 
   62 -> 91, 94 -> 10, 96 -> 81, 95 -> 75, 62 -> 77, 3 -> 87, 
   43 -> 87, 49 -> 24, 21 -> 87, 94 -> 39, 94 -> 98, 87 -> 89, 
   5 -> 13, 21 -> 67, 47 -> 5, 62 -> 47, 39 -> 47, 91 -> 60, 96 -> 76,
    10 -> 79};

gr2 = Graph[vertices, edges, VertexLabels -> "Name", ImagePadding -> 20, ImageSize->300];
Row[{gr2, fp = FixedPoint[vdF, gr2], HighlightGraph[gr2, EdgeList[fp]]}]

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.