Issue with EdgeLabels

Question

I want to reproduce Shannon's telegraph Markov chain from A Mathematical Theory of Communication.

EdgeLabels isn't doing the trick here:

telegraphGraph = Graph[
  {1 \[DirectedEdge] 2, 2 \[DirectedEdge] 1, 1 \[DirectedEdge] 2, 
   2 \[DirectedEdge] 1, 2 \[DirectedEdge] 2, 2 \[DirectedEdge] 2}(*,  
  EdgeLabels \[Rule] {1\[DirectedEdge]2 \[Rule] "DASH", 
  1\[DirectedEdge]2 \[Rule] "DOT", 2\[DirectedEdge]1 \[Rule] 
  "WORD SPACE",  2\[DirectedEdge]1 \[Rule] "LETTER SPACE",
  2\[DirectedEdge]2\[Rule] "DOT", 2\[DirectedEdge] 2\[Rule] 
  "DASH" }*), GraphStyle -> "BasicBlack"]

These are essentially duplicates: (92014) (74125) (17658) See the comments under the first one. To keep it simple, I wouldn't use Graph here because properties (such as edge labels) just don't work with multigraphs in Mathematica. It is a design bug. Consider writing to Wolfram Support about this, as the more people report the problem the more likely there will be something done about it. — Szabolcs, Dec 17 '16 at 16:32
Thanks @Szabolcs, I'll link this page in an email to WRI's support. — andandandand, Dec 17 '16 at 22:05

score 2 · Answer 1 · answered Oct 09 '17 at 04:28

edgepoints = {{{1, 0}, {1, 2}, {4, 2}, {4, 0}}, {{1, 0}, {1, 1}, {4, 1}, {4, 0}}};
loops = {{4, 0}, {4, 1.5}, {5, .5}, {4, 0}};
textcoords = {{5/2, -1.65}, {5/2, -.9}, {5/2, .9}, {5/2, 1.65}, {4.75, -.5}, {4.75, .5}};
labels = Style[#, 18] & /@ {"WORD SPACE", "LETTER SPACE", "DOT", "DASH", "DASH", "DOT"};
texts = Text @@@ Transpose[{labels, textcoords}]; 

beziercurves = {Arrowheads[{{.05, .7}}], Arrow[BezierCurve@#] & /@ 
    Join[{#, Reverse[{1, -1} # & /@ #]} & /@ edgepoints, {#, {1, -1} # & /@ #} &@loops]};

Graphics[{beziercurves, PointSize[.025], Point[{{1, 0}, {4, 0}}], texts}]

Issue with EdgeLabels

1 Answers1