Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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. >>
share|improve this question
    
Graph[{1 [UndirectedEdge] 2, 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 1}] –  Loie Benedicte Aug 3 '13 at 5:51
    
"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. –  cormullion Aug 3 '13 at 6:51
    
Possible duplicate of this Q&A. –  cormullion Aug 3 '13 at 6:55

4 Answers 4

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.

share|improve this answer
    
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. –  ubpdqn Aug 3 '13 at 12:58
    
I am getting used to commenting. Forgot to reference you in previous comment then locked out. Oh well. –  ubpdqn Aug 3 '13 at 13:06
    
@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! –  cormullion Aug 3 '13 at 13:17
    
very kind. Look forward to learning more from you and this environment. –  ubpdqn Aug 5 '13 at 10:26

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

share|improve this answer
    
very nice. FindShortestTour ideal. –  ubpdqn Aug 5 '13 at 10:25
    
+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... –  cormullion Aug 5 '13 at 15:34
    
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. –  halmir Aug 5 '13 at 17:15
    
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...:) –  cormullion Aug 5 '13 at 17:23
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

share|improve this answer
    
This is good, but how can I use it so that I can use the operator TravelingSalesman[g], for g a graph. –  Loie Benedicte Aug 3 '13 at 6:00
    
    
I do too. I got the same message... –  Loie Benedicte Aug 3 '13 at 6:29

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

share|improve this answer
    
I ran your code in my .nb file, but it wont run. What must I do to make this work? –  Loie Benedicte Aug 3 '13 at 7:17
    
Oh, and by the way, thank you. –  Loie Benedicte Aug 3 '13 at 7:18
    
Could you explain what your code does? –  Loie Benedicte Aug 3 '13 at 7:33
    
@loie It works fine. You probably need to clear out your current work first. Helpful post here –  cormullion Aug 3 '13 at 7:39
    
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. –  ubpdqn Aug 3 '13 at 7:44

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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