Generating custom GraphLayout for a hyperbolic graph

Question

I have code that generates a Matrix Mat (Mat = data) that, when the graph is plotted, AdjacencyGraph[Mat] gives a graph.

Now, there are many inbuilt functions for GraphLayout. Once we fix a particular GraphLayout. For a particular GraphLayout, we get the vertex coordinates when we use GraphEmbedding.

Let us take a simple example if I have a matrix for a square geometry (square lattice). Then its graph will have a square face. Following the previous paragraph strategy, I will get the coordinates for the vertices like {{0,0}, {0,1},...{0,Lx},...{Ly,Lx}}, where Lx and Ly is the number of vertices along x and y. That is related to the size of the matrix, which is (Lx X Ly) X (Lx X Ly). One can do this for honeycomb or triangle lattices.

However, my graph has higher connectivity that doesn't fall in the above case (meaning it's not Euclidean). Suppose I use the existing GraphLayout. Then the coordinates are not as per the hyperbolic plane. For instance, if I use the GraphLayout -> "SpringElectricalEmbedding" then it uses the particular mechanism (minimizing the spring energy, not important here) to have a graph layout. But it starts to be a problem if I plot different (hyperbolic) graphs, where it is fully messed up and doesn't look good. So I can't extract coordinates rightly.

As an input, I will give the matrix with particular connectivity between the vertices. For example, below, I give as an input a lattice {8,3} in the matrix form, which is a polygon with 8 sides, and at each vertex, three such polygons (octagon) meet. As an output, I want the coordinates for all the vertices so that the coordinates satisfy a hyperbolic distance formula distance[z1,z2]. In other words, it is a fixed distance with a hyperbolic metric. So is there a way to create a custom GraphLayout that does it?

On idea from my side. Maybe we can create an EdgeWeight that encodes the distance function that, in turn, dictates how two edges should be connected? (no idea how good it is, maybe not at all)

MWE:

Mat = data;
graphMat = GraphEmbedding[AdjacencyGraph[ConnectMat, VertexCoordinates -> Coords, VertexLabels -> None, ImageSize -> Large, GraphLayout -> "SpringElectricalEmbedding"]
 distance[z1_, z2_] :=  1./2 ArcCosh[1 + (2 Abs[z1 - z2]^2)/((1 - Abs[z1]^2) (1 - Abs[z2]^2))];

Update: Can we use the EdgeWeight function, perhaps? Where this EdgeWeight account for the hyperbolic distance?
One example from Euclidean (not exactly what want though using ChatGPT)

g = GridGraph[{10, 10}, VertexLabels -> "Name", 


EdgeWeight -> Range[1, 4 - 1/60, 1./60], 
   EdgeLabels -> "EdgeWeight"];

distance[v1_, v2_] := Norm[v1 - v2];

calculateLayout[g_, distance_] := 
  Module[{vertices, edges, layout}, vertices = VertexList[g];
   edges = EdgeList[g];
   layout = 
    AssociationThread[vertices, 
     Flatten[Outer[List, Range[10], Range[10]], 1]];
   Do[With[{v1 = First[edge], v2 = Last[edge]}, 
     While[distance[layout[v1], layout[v2]] > 
       PropertyValue[{g, edge}, EdgeWeight], 
      layout[v2] += 0.01*(layout[v1] - layout[v2])]], {edge, edges}];
   layout];

layout = calculateLayout[g, distance];

ambush = 
 Graph[g,(*VertexCoordinates->layout,*)VertexLabels -> "Name"(*,
  EdgeLabels->"EdgeWeight"*)]

GraphEmbedding[ambush]

I would have rather wanted to have the coordinates look like the values on the Edge instead of the original coordinates.

Answer 1

Not sure if the following is close to what you need, but the pretty pictures it can produce might be of interest.

We define a graph function that takes five arguments and Graph options.

The first argument controls the number of vertices of seed polygon, the second argument controls the rotation/reflections transformations, the third integer specifies the number of iterations, the fourth argument specifies the projection model as Poincare or Beltrami-Klein, the fifth argument controls tolerance used in rationalizing coordinates. The helper functions indexCoords, hCoords, getVertexCoords, getEdgeList and poincareESF are defined in the Code section below.

hyperbolicGraph[n_, m_, iter_ : 1, 
   layout : (Automatic | "Poincare" | "Beltrami") : "Poincare", pr_ : Automatic, 
   opts : OptionsPattern[]] /; (1/n + 1/m < 1/2) := 
 Module[{vl, el, vc,
    coords = indexCoords @ hCoords[n, m, iter, 
      layout, pr /. Automatic -> 10^-5]}, 
  vc = getVertexCoords @ coords; 
  el = getEdgeList @ coords; 
  vl = Range @ Length @ vc;
  Graph[vl, el, VertexCoordinates -> vc,
    EdgeShapeFunction -> poincareESF, opts]] 

Examples

Note: Before using hyperbolicGraph, you need to copy and execute the code in the Code section below.

Row[hyperbolicGraph[8, 3, 3, #, Automatic, 
    VertexShapeFunction -> None, 
    PlotLabel -> Style["n = 8 | m = 3 | iterations = 3 | layout : " <> #, 16], 
    ImageSize -> Large] & /@ {"Poincare", "Beltrami"}]

Replace 3 in the second argument with 7 to get:

Playing with Graph options for styling edges and vertices:

n = 8; m = 3;

table = Table[With[{ge = GraphEmbedding[#]}, 
  SetProperty[#,
   {EdgeStyle -> {e_ :> Directive[Red, Opacity[.6], 
      AbsoluteThickness[(1.1 - N @ Norm[Mean @ ge[[{e[[1]], e[[-1]]}]]]) 30], 
         CapForm["Round"]]}, 
      VertexStyle -> {v_ :> {Yellow, 
          AbsolutePointSize[(1.1 - N@Norm[ge[[v]]]) 25]}}}]] & @
  hyperbolicGraph[n, m, it, lo, Automatic, 
     PlotLabel -> Style[it, White, 16], 
     VertexShapeFunction -> "Point", GraphStyle -> "ThickEdge", 
     EdgeStyle -> {e_ :> 
        Directive[Opacity[.6], RandomColor[], CapForm["Round"]]}, 
     ImageSize -> 350, Background -> Black], 
 {lo, {"Poincare", "Beltrami"}}, {it, {0, 1, 2, 3}}];

Labeled[Grid[MapThread[Prepend]@
   {table, Style[Rotate[#, 90 Degree], 24] & /@ {"Poincare", "Beltrami"}}],
 Style[StringForm["  n = `` | m = `` | iterations = {0, 1, 2, 3}", n, m], 24], 
 {{Top, Left}}]

Further examples:

n = 3; layout = Automatic;

Grid[{hyperbolicGraph[n, 7, #, layout, Automatic, 
     ImageSize -> 200] & /@ Range[4], 
  hyperbolicGraph[n, 50, #, layout, Automatic, 
     ImageSize -> 200] & /@ Range[4]}]

With layout = "Beltrami" we get

With n = 4; layout = Automatic; we get

With n = 4; layout = "Beltrami"; we get

Column[Table[
  Row[hyperbolicGraph[8, 3, #, layout, Automatic, ImageSize -> 400, 
     VertexShapeFunction -> "Point", 
     VertexStyle -> Directive[Orange, PointSize[Small]]] & /@ {1, 2, 3}],
  {layout, {Automatic, "Beltrami"}}]]

---

Code

First, several functions for generation and transformations of lists of coordinates (these are slightly modified versions of functions I found inspecting the function GraphComputation`RegularHyperbolicTilingGraphGraphComputation`RegularHyperbolicTilingGraph):

ClearAll[hyperbolicRotation, hyperbolicReflection, growCoords,  seedCoords,
  hCoords, hyperbolicGraph]

hyperbolicRotation[z_, {c_, t_}] := 
 With[{w = ((z - c) E^(I t))/(1 - z Conjugate[c])},
   (c + w)/(1 +  w Conjugate[c])] 

hyperbolicReflection[coords_, n_, m_] /; (1/n + 1/m < 1/2) := 
 Nest[Append[#, hyperbolicRotation[#[[-2]], {#[[-1]], 2 π/m}]] &, coords, n - 2]

seedCoords[n_, m_] /; (1/n + 1/m < 1/2) := 
 Block[{r, v, s = Sin[π/n]^2  Sec[π/m]^2}, r = s/(1 - s); 
  v = Sqrt[1 + 2 r - 2 Sqrt[r (1 + r)] Sin[π (1/n + 1/m)]] Exp[I π/n ]; 
  NestList[hyperbolicRotation[#, {0, -2 π/n }] &, v, n - 1]]

growCoords[coords_, m_] := With[{n = Length[coords]}, 
  Map[hyperbolicReflection[#, n, m] &] @ Reverse[Partition[coords, 2, 1, 1], 2]]

We use the above functions to generate a nested list of coordinates:

hCoords[n_, m_, k_, op : (Automatic | "Poincare" | "Beltrami") : "Poincare", 
   pr_ : Automatic ] /; (1/n + 1/m < 1/2) := 
 Module[{opr = op /. 
   {Automatic | "Poincare" ->  Identity, 
   "Beltrami" -> (2 #/(1 + Abs[#]^2) &)}}, 
  Rationalize[Map[ReIm @* opr, 
    NestList[p |-> Flatten[growCoords[#, m] & /@ p, 1],
    {N @ seedCoords[n, m]}, k], {2}], pr /. Automatic -> 10^-5]]

Next, a few operators to get the edge list, vertex list and vertex coordinates from the coordinate list produced by hCoords:

indexCoords = Association @* DeleteDuplicatesBy[Sort @* First] @* 
  (Thread[ArrayComponents[#, 2] -> #] &) @* Last;

getEdgeList = DeleteDuplicatesBy[Sort] @* Apply[Join] @*
   Map[MapApply[UndirectedEdge]@Partition[#, 2, 1, 1] &] @* Keys;

getVertexCoords = DeleteDuplicates @* Apply[Join] @* KeyValueMap[Thread[#->#2]&];

For hyperbolic lines and segments we use the function GraphComputation`GraphChartDump`geo

GraphComputation`GraphPropertyChart;

poincareESF = GraphComputation`GraphChartDump`geo[.99 First[#], .99 Last[#], 
    "segment"] &;

poincareLine = GraphComputation`GraphChartDump`geo[.99 First[#], .99 Last[#], 
    "line"] &;

We now have all the pieces to define hyperbolicGraph:

hyperbolicGraph[n_, m_, iter_ : 1, 
   layout : (Automatic | "Poincare" | "Beltrami") : "Poincare", pr_ : Automatic, 
   opts : OptionsPattern[]] /; (1/n + 1/m < 1/2) := 
 Module[{vl, el, vc,
    coords = indexCoords @ hCoords[n, m, iter, 
      layout, pr /. Automatic -> 10^-5]}, 
  vc = getVertexCoords @ coords; 
  el = getEdgeList @ coords; 
  vl = Range @ Length @ vc;
  Graph[vl, el, VertexCoordinates -> vc,
    EdgeShapeFunction -> poincareESF, opts]] 

---

Poincare lines and segments

SeedRandom[12];
rp = RandomPoint[Disk[], {5, 2}];
colors = RandomColor[5];

Row[{Graphics[{Red, Circle[], Blue, PointSize[Large], 
    MapThread[{#, Point@#2} &]@{colors, rp}}, ImageSize -> 400],
  Graphics[{Red, Circle[], CapForm["Butt"], AbsoluteThickness[8], 
    Orange, poincareESF /@ rp, Gray, AbsoluteThickness[1], 
    poincareLine /@ rp, Blue, PointSize[Large], 
    MapThread[{#, Point@#2} &]@{colors, rp}}, ImageSize -> 400]}]

---

Fun with hCoords:

n = 3; m = 8;

Row[Graphics[{RandomColor[], Polygon @ #} & /@ 
   Flatten[hCoords[n, m, 4, #], 1], ImageSize -> 400] & /@ 
    {"Poincare", "Beltrami"}, Spacer[10]]

With n = 7; m = 3; we get