Callout: How to add to graphs?

Question

Description of Problem

Mathematica recently added Callout as a new labeling option. While I am preferential to using Tooltip, if one has to use the image in a presentation, it is nice to have labels. Further, while Placed allows one to designate where the label goes in respect to the vertex, I find that it does not exactly do so in a way that is easy to read - especially if some verticies are close together.

Question

So how can one use Callout with Graph option VertexLabels to get a clean labeling of a directed graph?

Example:

A basic graph

simpleGraph = {1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 3 \[DirectedEdge] 1, 1 \[DirectedEdge] 4, 4 \[DirectedEdge] 2};

Default labels

Graph[simpleGraph, VertexLabels -> "Name"]

Using Placed works

Graph[simpleGraph, VertexLabels -> Placed["Name", Above]]

Using Callout does not work

Graph[simpleGraph, VertexLabels -> Callout["Name", Above]]

Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 3 \[DirectedEdge] 1, 1 \[DirectedEdge] 4, 4 \[DirectedEdge] 2}, VertexLabels -> Callout[{1, 2, 3, 4}, {1, 2, 3, 4}, Above]]

Example of Desired Output

Because this image is wide, we will just zoom up at one part of it

Ideal:

I know making a automated label function that minimizes textual overlap with vertices is hard, but hopefully there is a way to at least get text to not overlap.

Sample graph to practice on:

exampleGraph={17835 \[DirectedEdge] 17848, 17848 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 17845, 17845 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 5779, 5779 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 3931, 3931 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 3870, 3870 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 3554, 3554 \[DirectedEdge] 20967, 
 17835 \[DirectedEdge] 3403, 3403 \[DirectedEdge] 20967, 
 20967 \[DirectedEdge] 12657, 12657 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 9038, 9038 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 5779, 5779 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 3870, 3870 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 3637, 3637 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 3554, 3554 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 3367, 3367 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 1390, 1390 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 560, 560 \[DirectedEdge] 17835, 
 20967 \[DirectedEdge] 482, 482 \[DirectedEdge] 17835};

An unsatisfying approach

Alternatively, a footnote like style would also be ok, e.g. a vertex has a number, and below the graph a table of number name pairs appears...

Functions

getVerticies[edgeList_] := Module[{vertexList = {}},
  Table[AppendTo[
    vertexList, {edgeList[[i]][[1]], edgeList[[i]][[2]]}], {i, 1, 
    Length[edgeList]}];
  Return[DeleteDuplicates[Flatten[vertexList]]]
  ]
makeVertexLabels[vertexList_, labelList_] := 
  Return[Table[
    vertexList[[i]] -> Placed[labelList[[i]], Center], {i, 1, 
     Length[vertexList]}]];
makeEdgeLabels[edgeList_, labelList_] := 
  Return[Table[
    edgeList[[i]] -> Placed[labelList[[i]], "Middle"], {i, 1, 
     Length[edgeList]}]];

Variables

simpleGraph = {1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 
  3 \[DirectedEdge] 1, 1 \[DirectedEdge] 4, 4 \[DirectedEdge] 2};
listOfVertexNames = {"One", "Fish", "Two", "Fish"};
listOfEdgeNames = {"Red", "Fish", "Blue", "Fish", "Octupus"};

Graph

Graph[simpleGraph, 
 VertexLabels -> 
  makeVertexLabels[getVerticies[simpleGraph], 
   Range[Length[getVerticies[simpleGraph]]]], 
 EdgeLabels -> 
  makeEdgeLabels[simpleGraph, Range[Length[simpleGraph]]]]

Table

verticies = 
 Prepend[Table[
   Range[Length[getVerticies[simpleGraph]]][[i]] -> 
    listOfVertexNames[[i]], {i, 1, Length[listOfVertexNames]}], 
  "Verticies"]
edges = Prepend[
  Table[Range[Length[simpleGraph]][[i]] -> listOfEdgeNames[[i]], {i, 
    1, Length[listOfEdgeNames]}], "Edges"]
Grid[{{Column[verticies]}, {Column[edges]}}, Alignment -> Left, 
 BaselinePosition -> Top]

Downsides: 1) I don't know how to guarantee that the vertex numbers fit inside the verticies. 2) nor do I know how to offset the edge labels sightly. 3) Requires more space for publications (because of the table), which means the graph has to be smaller.

Answer 1

One possible way is to ListPlot the vertex coordinates of the Graph object and Show the graph and list plot together:

gr=Graph[exampleGraph];

lp=ListPlot[Callout@@@Transpose[{GraphEmbedding[gr], VertexList[gr]}],
Axes->False, PlotStyle->None];

Show[gr, lp]

However ... without finer control on the Callout parameters, this is not much better than using VertexLabels->"Name":

Graph[exampleGraph, VertexLabels->"Name"]

Using labels as VertexShapeFunction gives a better picture:

Graph[exampleGraph, ImageSize -> 500, VertexShapeFunction -> "Name"]