2
$\begingroup$

Maybe this question is too hard. So I try to make a simple version to research.

Simulating a simple graph than that post.

SeedRandom[2]
p = RandomReal[1, {20, 2}];
sortPoint[p_] := 
 Module[{order = Last[FindShortestTour[p]]}, 
  If[RandomReal[] < .5, p[[Rest[order]]], p[[order]]]]
Graphics[line = Line /@ sortPoint /@ FindClusters[p, 5]]

Make it to be a graph

rule = Dispatch[MapIndexed[Rule[#, First[#2]] &, p]];
g = Graph[
  Catenate[Developer`PartitionMap[UndirectedEdge @@ # &, #, 2, 1] & /@
     Level[line /. rule, {2}]], 
  VertexCoordinates -> Reverse /@ Normal[rule]]

Add some additional edges between components each other

gLast = Fold[
  GraphUnion[#, #2, VertexCoordinates -> Reverse /@ Normal[rule], 
    VertexLabels -> "Name"] &, g, 
  Graph[UndirectedEdge @@@ Tuples[#]] & /@ 
   Subsets[ConnectedComponents[g], {2}]]

To make sure we can select these edge we want,we should make some essential variables.

var = Rule[addEdge @@ #, #] & /@ 
   Complement[EdgeList@gLast, EdgeList@g];
weightRule = 
  Rule[#, EuclideanDistance @@ (# /. Reverse /@ Normal[rule])] & /@ 
   Complement[EdgeList@gLast, EdgeList@g];
var2 = connectQ @@@ Keys[var];

But obviously the method of nikie's don't give integer always.

sol = Last[
   FindMinimum[{(Values[var] /. weightRule).var2, 
     And @@ Thread[0 <= var2 <= 1] && 
      And @@ Thread[
        Total /@ 
          Function[ind, Select[ind, MemberQ[var2, #] &]] /@ 
           Apply[connectQ, 
            IncidenceList[gLast, #] & /@ 
             ConnectedComponents[g], {2}] == 1]}, var2]];

As we see the result,we get some 0.5,neither 0 nor 1.But when we give a constraint such Element[var2, Integers].It will give some error information.

Values[sol] // Counts

<|1. -> 1, 0. -> 153, 0.5 -> 3|>

I think if we can solve this equation then the process in following become easy.Of course,if you have another smart solution,I'll glad to know.:)


ps: The result picture maybe like following.Of course,this is just an approximate guess.

$\endgroup$
5
$\begingroup$

The following code will help:

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

Let me explain how this code works:

  1. Our goal is to find a shortest connection between point groups (ConnectedComponents). So the first thing we should do is to find out the shortest distance between each tuple.

    The first five lines of my code is doing this job: Find out ConnectedComponents, then determine those points' position. Finally create list pre by calculating the distance between each tuple of points in each tuple of ConnectedComponents and single out the shortest connection in each tuple of ConnectedComponents.

  2. Find the shortest path that can connect this whole graph together.

    If we want to get the shortest connection, then it must be a tree, FindSpanningTree will do the job~ Check the code generating spt.

  3. Take the result and reform them into the form we would love to see.

    Take the edges' in spt and reform them back to the edges in the original graph. Check the code generating res.

  4. Presentation

    Quite simple~ Check the rest of the code~

The result will be as follow:

the result is just as you wanted

the value shown in the graph is the minimum distance.


UPDATE

A version if you want to use it everywhere! The only thing you should do is paste this code everywhere and set the input graph's name to gorig!

l = VertexList@gorig;
coor = PropertyValue[{gorig, #}, VertexCoordinates] & /@ l;
g = Graph[Range@Length@l, EdgeList@gorig /. 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$
  • $\begingroup$ I suppose this code works for the harder post too~ :) $\endgroup$ – Wjx Jun 10 '16 at 14:12
  • $\begingroup$ Thanks!Good luck in the examination. :) $\endgroup$ – yode Jun 10 '16 at 16:36
  • $\begingroup$ NOOOOOOO!!! The exam has been cancelled cause someone comporomised the test material!!! $\endgroup$ – Wjx Jun 10 '16 at 22:47
  • $\begingroup$ Sorry to hear that. $\endgroup$ – yode Jun 10 '16 at 23:39
  • $\begingroup$ I have to say that your FindSpanningTree replace my FindMinimum is a wonderful idea. $\endgroup$ – yode Jun 10 '16 at 23:41
0
$\begingroup$

Original method:

ConnectSeparateGraphCost[graph_] := 
 Module[{rule, cc, minWeightInCom, allMinEdge, spanTreeEdge, 
   completeGraph}, 
  rule = Dispatch[
    MapThread[Rule, {VertexList[graph], GraphEmbedding[graph]}]];
  cc = ConnectedComponents[graph];
  minWeightInCom = 
   First@MinimalBy[#, Last] & /@ 
    Map[{#, EuclideanDistance @@ (# /. rule)} &, 
     Tuples /@ Subsets[cc, {2}], {2}];
  allMinEdge = UndirectedEdge @@@ First /@ minWeightInCom;
  spanTreeEdge = 
   EdgeList[
    FindSpanningTree[
     completeGraph = 
      CompleteGraph[Length@cc, EdgeWeight -> Last /@ minWeightInCom]]];
  EdgeAdd[graph, 
   allMinEdge[[EdgeIndex[completeGraph, #] & /@ spanTreeEdge]]]]

Update the efficacy:

ConnectSeparateGraph[graph_] := 
 Module[{rule, pts, f, var1, var2, nearePoint, completeGraph}, 
  rule = Dispatch[
    MapThread[Rule, {VertexList[graph], GraphEmbedding[graph]}]];
  pts = WeaklyConnectedComponents[graph] /. rule;
  f = Nearest /@ Most[pts];
  var2 = Drop[pts, #] & /@ Range[Length[pts] - 1];
  var1 = MapThread[Catenate /@ # /@ #2 &, {f, var2}];
  nearePoint = 
   Catenate[
    Map[First[MinimalBy[#, EuclideanDistance @@ # &]] &, 
     Flatten[{var1, var2}, List /@ {2, 3, 4, 1, 5}], {2}]];
  completeGraph = 
   CompleteGraph[Length[pts], 
    EdgeWeight -> EuclideanDistance @@@ nearePoint];
  EdgeAdd[graph, 
   UndirectedEdge @@@ (nearePoint[[EdgeIndex[completeGraph, #] & /@ 
         EdgeList[FindSpanningTree[completeGraph]]]] /. 
      Reverse /@ Normal[rule])]]

When the separate component is 50:

g=(Uncompress@*FromCharacterCode@*Flatten@*(ImageData[#1, "Byte"] &)@*
   Import)["https://ooo.0o0.ooo/2017/02/18/58a8035aae255.png"];

ConnectSeparateGraphCost[g]; // AbsoluteTiming(*old method*)
ConnectSeparateGraph[g]; // AbsoluteTiming(*updated method*)
ConnectSeparateGraphCost[g] == ConnectSeparateGraph[g]

{2.18698, Null}

{0.329665, Null}

True

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