Need tips on improving this directed graph

Question

First we define a function that returns the least odd prime factor.

lopf[n_] := FactorInteger[n][[2, 1]]

Then we craft a routine that performs the 3x+1 steps using only primes

t = {};
z = 4;
While[z < 501,
 y = Prime[z++];
 prev = y;
 u = {};
 x = y;
 While[x >= y,
  prev = x;
  x = lopf[3 x + 1];
  u = AppendTo[u, {DirectedEdge[prev, x]}];
  t = AppendTo[t, u];
  ]
 ]
t = Union[Flatten[t]];

Then we graph it

Graph[t]

How can we structure this graph in a more civilized manner? I would like to have the first 5 primes {7,11,17,13,5} placed vertically down the center of a .pdf page and the remaining primes clustered about them.

Also, Is there a way to use a rollover to identify a prime represented by a dot? This would be handy within an interactive document.

Answer 1

  g = Graph[Tooltip /@ t, 
  VertexSize -> 
  Append[Thread[{5, 7, 11, 13, 17} -> {"Scaled", .01}, List, 1], {"Scaled", .005}],
  VertexStyle -> Thread[{5, 7, 11, 13, 17} -> Red],
  VertexLabels -> Placed["Name", Tooltip], 
  GraphLayout -> "RadialDrawing", ImageSize -> 700] //  Rotate[#, 90 Degree] &

gives

Does not quite line up the nodes for the first five primes in the list, but it is a cheap alternative to building a custom layout from scratch using VertexCoordinates.

EDIT: If the size of graph is reduced, one can use GraphPlot and its options to vertically line up the first five nodes. For this to work, I had to reduce the number of nodes to plot:

 tX = {}; z = 4; While[z < 240, y = Prime[z++]; prev = y; u = {};  x = y; 
 While[x >= y, prev = x; x = lopf[3 x + 1]; 
 u = AppendTo[u, {DirectedEdge[prev, x]}]; tX = AppendTo[tX, u];]];
 tX = Union[Flatten[tX]];
 tX2 = tX /. DirectedEdge[x_, y_] :> Rule[x, y];

With this dataset

 GraphPlot[tX2, PlotStyle -> Gray, 
 VertexRenderingFunction -> Function[{p, l}, 
  Tooltip[{If[MemberQ[{5, 7, 11, 13, 17}, l], 
  Sequence @@ {Red, PointSize[.015]}, 
  Sequence @@ {Blue, PointSize[.008]}], Point[p]}, Text[l]]], 
 VertexCoordinateRules ->  Thread[{5, 7, 11, 13, 17} -> {0, Automatic}, List, 1], 
 DirectedEdges -> True,
 ImageSize -> 400]

gives

EDIT 2: Aligning the first 5 nodes in graph g above:

coordlist = PropertyValue[{g, #}, VertexCoordinates] & /@ VertexList[g][[;; 5]];
coordlist[[All, 2]] = 4;
Fold[SetProperty[{#1, #2}, 
    VertexCoordinates -> coordlist[[VertexIndex[g, #2]]]] &, g, 
       VertexList[g][[;; 5]]] 
// Rotate[#, 270 Degree] &