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

$\endgroup$
2
  • $\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$
    – user484
    Mar 31, 2016 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, 2016 at 1:11

2 Answers 2

8
+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$
2
  • $\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, 2016 at 3:52
  • 4
    $\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, 2016 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 and acknowledge you have read our privacy policy.

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