5

Assume I have a graph.You can run following code to get it.

nearGraph =Import["http://halirutan.github.io/Mathematica-SE-Tools/decode.m"][
  "https://i.stack.imgur.com/TWP6J.png"]

Mathematica graphics

It is a disconnected graph.But I can connect it every component in this method.

SeedRandom[331]
pathGraph = 
 PathGraph[
  v = point[[Last@
      FindShortestTour[
       point = RandomChoice /@ ConnectedComponents[nearGraph]]]], 
  VertexCoordinates -> Most@v]

Mathematica graphics

Union this graph with original graph.

resultGraph = GraphUnion[nearGraph, pathGraph];
HighlightGraph[
 Graph[resultGraph, 
  VertexCoordinates -> VertexList[resultGraph]], pathGraph]

Mathematica graphics

{KEdgeConnectedGraphQ[resultGraph, 1],KEdgeConnectedGraphQ[resultGraph, 2]}

{True, False}

Yep.It's a connected now.But I don't really content with it.In my expectation.I wanna get a graph (maybe) like:

Mathematica graphics

It just cost a shortest edge can do this.I know the position or distance in Graph will not impact the result of calculation.In some case I have a demand like this maybe.I think we can see the distance as a edge weight to solve it.But I don't know how to implement it.

Update

As the @Rahul comments.I reemphasize the target that is the title of this topic :). We want to get a 1-edge-connected(but not 2-edge-connected).It can be the picture of the following

yode
  • 26,686
  • 4
  • 62
  • 167
  • Is it necessary that the new edges form (conceptually) a cycle? Would it not be allowed for the bottom red edge to go from the bottom left component to the component above the bottom right one instead? –  Mar 31 '16 at 00:52
  • @Rahul Yes,it is allowed completely.Actually I don't know my sketch graph whether or not exact.It just need cost shortest edge and make it be 1-edge-connected. – yode Mar 31 '16 at 01:11

2 Answers2

8
g = nearGraph;
cc = ConnectedComponents@g; 
orderComps = Last@FindShortestTour[#] &@(Mean /@ cc); 
nfs = Nearest /@ (cc[[#]] & /@ orderComps); 
mins = MapThread[ Function[{nf, points}, SortBy[{#, First@nf@#} & /@ points, 
                  EuclideanDistance @@ # &][[1]]][##] &,
                 {nfs,  RotateRight[cc[[orderComps]], 1]}];
ud = UndirectedEdge @@@ mins;
HighlightGraph[EdgeAdd[g, ud], ud]

Almost!

Mathematica graphics

Dr. belisarius
  • 115,881
  • 13
  • 203
  • 453
  • 1)I try to understand the code.it look very nice.But a inexplicable edge will be add(the left loop).2)I have some worry about the method use the Mean /@ cc to sort the connected component in some complicated case.But the FindShortestTour not support the Interval.3)I don't sure the result must be a cycle.like the comment mention – yode Mar 31 '16 at 03:52
  • 4
    Dr. belisarius, you seem to be taking a break from Stack Exchange, but I want to congratulate you on breaking the 100k "reputation" barrier, for what that is worth to you. :-) – Mr.Wizard Jun 03 '16 at 07:17
1

Just carry Wjx's code for this problem.Maybe more beauty solution can do this.

l = VertexList@neargraph;
coor = PropertyValue[{neargraph, #}, VertexCoordinates] & /@ l;
g = Graph[Range@Length@l, EdgeList@neargraph /. Thread[l -> Range@Length@l], 
   VertexCoordinates -> coor];

cc = ConnectedComponents@g;
pts = Map[{#, PropertyValue[{g, #}, VertexCoordinates]} &, cc, {2}];
pre = First@MinimalBy[#, Last] & /@ 
   Apply[{#1[[1]] <-> #2[[1]], Norm[#1[[2]] - #2[[2]]]} &, 
    Tuples /@ Subsets[pts, {2}], {2}];
spt = EdgeList@
   FindSpanningTree[
    CompleteGraph[Length@cc, EdgeWeight -> pre[[;; , 2]]]];
res = Extract[pre, 
   First@Position[
       UndirectedEdge @@@ Subsets[Range@Length@cc, {2}], #] & /@ spt];
res[[;; , 2]] // Total
HighlightGraph[g~EdgeAdd~res[[;; , 1]], res[[;; , 1]]]

yode
  • 26,686
  • 4
  • 62
  • 167