Message Boards Message Boards

0
|
1664 Views
|
3 Replies
|
3 Total Likes
View groups...
Share
Share this post:

Changed methods for displaying Graphs (networks)

Hello, All! Back in 2011 The Mathematica Journal published this article I wrote: https://www.mathematica-journal.com/2011/05/11/indexing-strings-and-rulesets/

I needed to refer to Cantor's idea for enumerating the rational numbers by taking diagonal stripes through a doubly infinite table listing all fractions with all positive integer numerators and denominators, and rather than finding an image somewhere I wrote some code to generate the image as a Graph object.
Cantor's diagonal enumeration of all fractions
Here's the code, which actually still runs under Mathematica 13.1, but with deprecated Options showing in red all over the place:

Successor[{n_Integer, d_Integer}] :=  If[d == 1, {1, (n + 1)}, {(n + 1), (d - 1)}]; 
display[{n_, d_}] :=  Style[Which[n == d == 6, "\[DescendingEllipsis]", n == 6, 
   "\[CenterEllipsis]", d == 6, "\[VerticalEllipsis]", True, ToString@Row[{n, d}, "/"]], 20];
GraphPlot[(DeleteCases[#1, Null] &)[Flatten[
   Table[{{n, d} -> {n, d}, If[(n <= 7 && d <= 7 && n + d <= 6 && n < 6), {n, d} -> 
       Successor[{n, d}]]}, {d, 1, 6}, {n, 1, 6}], 3]], 
 DirectedEdges -> True, VertexLabeling -> True, SelfLoopStyle -> False,
 VertexCoordinateRules -> Flatten[Table[{n, d} -> {n, 6 - d}, {d, 1, 6}, {n, 1, 6}], 1], 
 VertexRenderingFunction -> (If[#2[[1]] < 6 && #2[[2]] < 6,
     {EdgeForm[None], Hue[.8 + .09 Plus @@ #2], 
      Rectangle[#1 - {0.33, .26}, #1 + {0.33, .31}, 
       RoundingRadius -> .11], Black, Text[display@#2, #1]}, Text[display@#2, #1]] &),
 EdgeRenderingFunction -> ({If[#2[[1]][[2]] == 1, Red, Blue], 
     Arrow[#1, If[#2[[1]][[1]] == #2[[2]][[1]] == 1, 0.35, .33]]} &),
 AspectRatio -> .7]

Many of these Options for GraphPlot have been replaced by other and more powerful options for Graph. I know I just need to pore over and absorb all the online help examples for Graph, but if anyone here has the time and skills to "translate" this code into Mathematica v.13, I would really appreciate it!

Needed:
(1) Place the vertices as specified, {n,d} is placed in the nth column, dth row.
(2) Format vertices to display {n,d} as n/d in a RoundedRectangle, with fill color assigned by Hue varying as we traverse the enumeration.
(3) Two different edge forms: Blue Arrows for the diagonal steps up and to the right, Red ones (or now I'd probably use a dotted line or arrow) for the retraces connecting one stripe to the next.

Anyone interested / challenged? Many thanks!

Ken

POSTED BY: Ken Caviness
3 Replies

The DirectedEdges, VertexLabeling, and SelfLoopStyle options can be dropped.

The edges can be constructed with DirectedEdge instead of Rule.

The option VertexCoordinateRules is changed to VertexCoordinates, and VertexRenderingFunction is changed to VertexShapeFunction.

The handling of self-loops is incorporated into the EdgeShapeFunction (formerly EdgeRenderingFunction).

Here is the full code:

Successor[{n_Integer, d_Integer}] := If[d == 1, {1, (n + 1)}, {(n + 1), (d - 1)}];

display[{n_, d_}] := Style[Which[n == d == 6, "\[DescendingEllipsis]", n == 6, "\[CenterEllipsis]", d == 6, "\[VerticalEllipsis]", True, ToString@Row[{n, d}, "/"]], 20]

edges = (DeleteCases[#1, Null] &)[ Flatten[Table[{{n, d} \[DirectedEdge] {n, d}, If[(n <= 7 && d <= 7 && n + d <= 6 && n < 6), {n, d} -> Successor[{n, d}]]}, {d, 1, 6}, {n, 1, 6}], 3]]

Graph[edges, VertexCoordinates -> Flatten[Table[{n, d} -> {n, 6 - d}, {d, 1, 6}, {n, 1, 6}], 1], VertexShapeFunction -> (If[#2[[1]] < 6 && #2[[2]] < 6, {EdgeForm[ None], Hue[.8 + .09 Plus @@ #2], Rectangle[#1 - {0.33, .26}, #1 + {0.33, .31}, RoundingRadius -> .11], Black, Text[display@#2, #1]}, Text[display@#2, #1]] &), EdgeShapeFunction -> (If[ MatchQ[#2, x_ \[DirectedEdge] x_], {}, {If[#2[[1]][[2]] == 1, Red, Blue], Arrow[#1, If[#2[[1]][[1]] == #2[[2]][[1]] == 1, 0.35, .33]]}] &), AspectRatio -> .7 ]

And here is the result:

enter image description here

POSTED BY: Robert Nachbar

Many thanks, Robert! I appreciate this, and you encourage me to look beyond my sense of "everything's different!" -- this looks like less of a learning curve than I feared.

POSTED BY: Ken Caviness

By the way, if you notice this graphic floating around the web -- as I have! -- please drop me a line so I can ask them to give proper credit for it. Of course, the idea does go back to Georg Cantor, but this particular implementation of the diagram, with the changing Hue, arrows & retrace arrows to show the enumeration order -- it's mine. The original source is https://www.mathematica-journal.com/2011/05/11/indexing-strings-and-rulesets/

POSTED BY: Ken Caviness
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract