4
$\begingroup$

I'm trying to create the following graph in Mathematica

Where do I start? I'm specifically trying to make a graph so that I can use it in TravelingSalesman[g], for g a graph. This is what I have:

g := Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 3, 
   1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 4, 
   4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 3, 
   4 \[UndirectedEdge] 2, 3 \[UndirectedEdge] 5, 
   3 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 5}, 
  EdgeWeight -> {4, 5, 6, 3, 4, 5, 6, 7, 2, 7}]

Calling

TravelingSalesman[g]

I get the following result:

Table::iterb: Iterator {Combinatorica`Private`i$828,V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

Join::heads: Heads Combinatorica`Private`Double and Table at positions 1 and 2 are expected to be the same. >>

Join::heads: Heads Combinatorica`Private`Double and Table at positions 1 and 2 are expected to be the same. >>

Join::heads: Heads Combinatorica`Private`Double and List at positions 1 and 2 are expected to be the same. >>

General::stop: Further output of Join::heads will be suppressed during this calculation. >>

Table::iterb: Iterator {V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

Table::iterb: Iterator {V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

General::stop: Further output of Table::iterb will be suppressed during this calculation. >>

Range::range: Range specification in Range[V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]] does not have appropriate bounds. >>

TravelingSalesman::ham: The graph must contain a Hamiltonian cycle for a traveling salesman tour to be found. >>
$\endgroup$
3
  • $\begingroup$ Graph[{1 [UndirectedEdge] 2, 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 1}] $\endgroup$ Aug 3, 2013 at 5:51
  • $\begingroup$ "To use TravelingSalesman, you first need to load the Combinatorica Package using Needs["Combinatorica`"]." But this is now deprecated in favour of the built-in graph functions. $\endgroup$
    – cormullion
    Aug 3, 2013 at 6:51
  • $\begingroup$ Possible duplicate of this Q&A. $\endgroup$
    – cormullion
    Aug 3, 2013 at 6:55

4 Answers 4

6
$\begingroup$

Mathematica's graphing features are very powerful, but I find them confusing - there seems to be two separate types of graphing function (not including the deprecated "Combinatorica" system), and not all of the documentation has been written or updated that needs to be. But here's some more ideas for you to play with, to supplement the existing answers.

Some basic data:

data = {{"a" \[UndirectedEdge] "b" -> 3}, 
        {"a" \[UndirectedEdge] "e" -> 5},
        {"a" \[UndirectedEdge] "c" -> 6},
        {"a" \[UndirectedEdge] "d" -> 4}, 
        {"b" \[UndirectedEdge] "c" -> 4}, 
        {"b" \[UndirectedEdge] "e" -> 5}, 
        {"b" \[UndirectedEdge] "d" -> 6}, 
        {"c" \[UndirectedEdge] "e" -> 7}, 
        {"c" \[UndirectedEdge] "d" -> 8}}

from which you can extract the edges and the edge weights:

edges = data[[All, 1, 1]];
edgeweights = data[[All, 1, 2]];

So here's the basic graph:

g = Graph[edges, 
  EdgeWeight -> edgeweights, 
  EdgeLabels -> "EdgeWeight",
  VertexLabels -> "Name", 
  DirectedEdges -> False]

graph

You can use GraphDistance to find the distance between vertices:

GraphDistance[g, #] & /@ VertexList[g]

{{0, 3., 5., 6., 4.}, 
 {3., 0, 5., 4., 6.}, 
 {5., 5., 0, 7., 9.}, 
 {6., 4., 7., 0, 8.}, 
 {4., 6., 9., 8., 0}}

Then you apply a similar process to a list of all the cycles:

cycles = Table[
    {
     Total[GraphDistance[g, First[#], Last[#]] & /@ cycle], 
     cycle
    }, 
  {cycle, FindHamiltonianCycle[g, All]}]

This adds the distances up for each Hamiltonian cycle.

{{29., {"a" <-> "e", "e" <-> "c", "c" <-> "d", "d" <-> "b", "b" <-> "a"}}, 
 {27., {"a" <-> "b", "b" <-> "e", "e" <-> "c", "c" <-> "d", "d" <-> "a"}}, 
 {26., {"a" <-> "d", "d" <-> "c", "c" <-> "b", "b" <-> "e", "e" <-> "a"}}, 
 {30., {"a" <-> "c", "c" <-> "d", "d" <-> "b", "b" <-> "e", "e" <-> "a"}}, 
 {26., {"a" <-> "e", "e" <-> "c", "c" <-> "b", "b" <-> "d", "d" <-> "a"}}, 
 {28., {"a" <-> "c", "c" <-> "e", "e" <-> "b", "b" <-> "d", "d" <-> "a"}}}

Sort this:

sortedCycles = Sort[cycles, First[#1] < First[#2] &];

and you can show them using HighlightGraph:

HighlightGraph[g, #, GraphHighlightStyle -> "Thick", 
    ImageSize -> 200] & /@ sortedCycles[[All, 2]]

array of graphs

Getting the graphs to look like your original is the next step. Create a layered graph using LayeredGraphPlot, and extract the vertices from it:

vc = VertexCoordinateRules /. 
   Cases[LayeredGraphPlot[AdjacencyMatrix[g]], _Rule, Infinity]

(LayeredGraphPlot is one of the "old" graphing functions, producing graphics and graphics complexes rather than Graph objects.)

Now apply these vertex coordinates to a new graph, defined as before:

h = Graph[edges, 
  EdgeWeight -> edgeweights, 
  EdgeStyle -> LightGray,
  EdgeLabelStyle -> Directive[{FontFamily -> "Zapfino", 16, Red}],
  EdgeLabels -> Flatten[data, 1], 
  VertexLabels -> "Name", 
  VertexLabelStyle -> Directive[{FontFamily -> "Futura", 16, Purple}],
  DirectedEdges -> False, 
  VertexCoordinates -> vc]

another graph

which is starting to move close to your original.

I don't know how to create the curved edges. But when I start to play with the fonts and colors, it's an indication that it's time to stop.

$\endgroup$
4
  • $\begingroup$ I enjoyed your solution and your humour (last phrase). I think my coding of graph matches handwritten, edge 3 -4 weight as 7 and I get a unique solution. Your graph coding matches the graph prepared by Nasser with 3-4 weight 8 and there are two cycles with minimum 26. This is of no particular interest, I just like to understand. If I am wrong let me know. $\endgroup$
    – ubpdqn
    Aug 3, 2013 at 12:58
  • $\begingroup$ I am getting used to commenting. Forgot to reference you in previous comment then locked out. Oh well. $\endgroup$
    – ubpdqn
    Aug 3, 2013 at 13:06
  • $\begingroup$ @ubpdqn :) I didn't refer to the sketch - Nasser did the hard work and I shamelessly copied his data ... I like your blog, by the way! $\endgroup$
    – cormullion
    Aug 3, 2013 at 13:17
  • $\begingroup$ very kind. Look forward to learning more from you and this environment. $\endgroup$
    – ubpdqn
    Aug 5, 2013 at 10:26
5
$\begingroup$

You could create weighted adjacency matrix to use as distance matrix in FindShortestTour:

g = Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 3, 
  1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 4, 
  4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 3, 
  4 \[UndirectedEdge] 2, 3 \[UndirectedEdge] 5, 
  3 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 5}, 
  EdgeWeight -> {4, 5, 6, 3, 4, 5, 6, 7, 2, 7}, 
  VertexLabels -> Placed["Name", Center],    
  VertexSize -> .3, EdgeLabels -> "EdgeWeight", 
  GraphLayout -> "LayeredDigraphEmbedding", ImagePadding -> 5];

d = ((WeightedAdjacencyMatrix[g] // Normal) /. {0 -> Infinity});

{len, tour} = FindShortestTour[Range[VertexCount[g]], 
     DistanceFunction ->   (d[[#1, #2]] &)]

HighlightGraph[g, UndirectedEdge @@@ Partition[VertexList[g][[tour]], 2, 1, 1], 
 GraphHighlightStyle -> "Thick"]

enter image description here

$\endgroup$
4
  • $\begingroup$ very nice. FindShortestTour ideal. $\endgroup$
    – ubpdqn
    Aug 5, 2013 at 10:25
  • $\begingroup$ +1 Very nice! I presume the shortest tour doesn't return to base - so it's 1->2->3->4->5 (despite the red path from 5 to 1)? - whereas the Hamiltonian cycles return home... $\endgroup$
    – cormullion
    Aug 5, 2013 at 15:34
  • $\begingroup$ I missed the point that tour is based on vertex index. I edited to fix that. @cormullion FindShortestTour indeed return to base. You can check it by looking at length of tour which include the final trip to 1. $\endgroup$
    – halmir
    Aug 5, 2013 at 17:15
  • $\begingroup$ Yes that now kind of agrees with the result I got (allowing for the fact that the OP's drawing and graph disagree with each other...:) $\endgroup$
    – cormullion
    Aug 5, 2013 at 17:23
3
$\begingroup$
SetDirectory[NotebookDirectory[]];
img = Import["a.png"];

g = LayeredGraphPlot[{{"a" -> "b", 3}, {"a" -> "e", 5}, {"a" -> "c", 6}, {"a" -> "d", 
     4}, {"b" -> "c", 4}, { "b" -> "e", 5}, {"b" -> "d", 
     6}, {"c" -> "e", 7}, { "c" -> "d", 8}}, 
   PlotStyle -> {Opacity[.5], Gray}, 
   BaseStyle -> {Bold, FontSize -> 24}, VertexLabeling -> True, 
   VertexRenderingFunction -> (Inset[Framed[Style[#2, 22], Background -> White,
      FrameStyle -> Gray], #1, {Center, Top}] &), DirectedEdges -> False, 
      PlotRangePadding -> Automatic,ImageSize -> 450];

Grid[{{img, g}}, Frame -> All]

Mathematica graphics

$\endgroup$
3
2
$\begingroup$

This is a small graph and the unweighted graph has a number of Hamiltonian cycles. I assume the aim is to find the one with minimum cost/weight. This is an approach. I have changed the vertices a,b,c,d,e to 1,2,3,4,5.

g = Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3, 
   3 \[UndirectedEdge] 4, 4 \[UndirectedEdge] 1, 
   1 \[UndirectedEdge] 3, 3 \[UndirectedEdge] 5, 
   4 \[UndirectedEdge] 5, 2 \[UndirectedEdge] 5, 
   1 \[UndirectedEdge] 5, 2 \[UndirectedEdge] 4}, 
  EdgeWeight -> {3, 4, 7, 4, 6, 7, 2, 5, 5, 6}, 
  VertexLabels -> "Name", EdgeLabels -> "EdgeWeight"];
h = FindHamiltonianCycle[g, All];
norm = Normal@WeightedAdjacencyMatrix[g];
ans = Total /@ (Extract[norm, #] & /@ (# /. 
        a_ \[UndirectedEdge] b_ :> {a, b}) & /@ h);
min = Extract[h, Position[ans, Min[ans]]]
HighlightGraph[g, min, GraphHighlightStyle -> "Thick"]

If I have coded your graph in error I apologise. It would be helpful to code the graph (vertices, edges and edgeweights).

enter image description here

$\endgroup$
6
  • $\begingroup$ I ran your code in my .nb file, but it wont run. What must I do to make this work? $\endgroup$ Aug 3, 2013 at 7:17
  • $\begingroup$ Oh, and by the way, thank you. $\endgroup$ Aug 3, 2013 at 7:18
  • $\begingroup$ Could you explain what your code does? $\endgroup$ Aug 3, 2013 at 7:33
  • $\begingroup$ @loie It works fine. You probably need to clear out your current work first. Helpful post here $\endgroup$
    – cormullion
    Aug 3, 2013 at 7:39
  • $\begingroup$ What version of Mathematica are you using? I wrote this in version 9. I have rerun on my machine (old). It works ok. (i) g just codes the weighted graph (ii) h finds all the Hamiltonian cycles in g (achievable for small graph) (iii) norm just creates the weighted (symmetric) adjacency graph from which to extract weights (iv)ans just total the weights for the found cycles (v) min extracts the one with minimum weight (vi) the last command just highlights the cycle on the original graph. You could do with older versions but I have lost familiarity. I hope this helps. $\endgroup$
    – ubpdqn
    Aug 3, 2013 at 7:44

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.