5
$\begingroup$

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

nearGraph =Import["http://halirutan.github.io/Mathematica-SE-Tools/decode.m"][
  "http://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

$\endgroup$
  • $\begingroup$ 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? $\endgroup$ – Rahul Mar 31 '16 at 0:52
  • $\begingroup$ @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. $\endgroup$ – yode Mar 31 '16 at 1:11
7
+100
$\begingroup$
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

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – yode Mar 31 '16 at 3:52
  • 3
    $\begingroup$ 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. :-) $\endgroup$ – Mr.Wizard Jun 3 '16 at 7:17
1
$\begingroup$

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

$\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.