Random graphs in Poincare disk

Question

The question is inspired by that article ( see Wiki as a first reading on the topic). This is an actual topic of modern mathematical physics. Here is my (partly successful) attempt to implement such graphs in Mathematica.

Let a graph be located in Disk[{0,0},r] (of hyperbolic radius R = ArcCosh[1 + 2/(1 - r^2)]). First, we create a random set of its vertices by

r = 99/100; R = ArcCosh[1 + 2/(1 - r^2)]; SeedRandom[1234]; 
vertices = Table[{RandomVariate[UniformDistribution[{0, 2*Pi}], 1][[1]], 
RandomVariate[ProbabilityDistribution[Sinh[t]/(-1 + Cosh[R]), {t, 0, R}], 1][[1]]}, {j, 1, 30}];

, following formula (1) from the linked article with \[Alpha]=1. Second, we create a random set of its edges by

edges = Apply[UndirectedEdge, #] & /@ RandomSample[Subsets[vertices, {2}], 80];

We choose 80 random two-elemented subsets of vertices by RandomSample[Subsets[vertices, {2}], 80] and then transform the ones to edges by Apply[UndirectedEdge, #] & /@.

Now

Graph[vertices, edges, VertexCoordinates -> 
Table[vertices[[j]] -> {vertices[[j]][[2]]*Cos[vertices[[j]][[1]]], 
vertices[[j]][[2]]*Sin[vertices[[j]][[1]]]}, {j, 1,  Dimensions[vertices][[1]]}]]

The coordinates of vertices are polar $(\phi,r)$ so we have to change these to cartesian coordinates.

The above is a somewhat unfinished work.

(i) Physicists often use the following construction: any two vertices $u$ and $v$ are connected by an edge if their hyperbolic distance $\textrm{dist}H(u, v)$ is below a certain number $\rho$. Neither BernoulliGraphDistribution nor BarabasiAlbertGraphDistribution realize it. How to do it?

(ii) In the above edges are drawn as lines. How to draw edges as hyperbolic lines ( compare (a) and (b) in Fig. 1) ?

Answer 1

(i) You can use NearestNeighborGraph with the appropriate manually defined DistanceFunction. If that function gives you trouble, use AdjacencyGraph@Unitize@UnitStep@DistanceMatrix[points, DistanceFunction -> ...].

(ii) Use an appropriate manually defined EdgeShapeFunction.

Most of the work will be constructing the correct distance function and edge shape function, but those are more of a mathematical problem than a Mathematica one.

Answer 2

Szabolcs's suggestion was pretty straightforward to implement, and the math for the Poincaré disk is easy (for those who are familiar with it), so just for giggles, here's my take:

(* https://mathematica.stackexchange.com/a/115580 *)
poincareMetric[u_?VectorQ, v_?VectorQ] := 
        Abs[ArcCosh[1 + 2 SquaredEuclideanDistance[u, v]/((1 - u . u) (1 - v . v))]]

(* NURBS representation of a line on the Poincaré disk *)
poincareLine[{p1_, p2_}] := Module[{s = p1 . p2 - 1, tm = Transpose[{p2, p1}]},
        BSplineCurve[{p1, tm . ({p1 . p1, p2 . p2} - 1)/(2 s), p2}, 
                     SplineDegree -> 2, SplineKnots -> {0, 0, 0, 1, 1, 1}, 
                     SplineWeights -> {1, 1/Sqrt[1 + (Det[tm]/s)^2], 1}]]

With[{n = 200 (* number of points *),
      r = 3, (* hyperbolic radius of disk *)
      h = 0.35 (* fraction of radius to consider drawing an edge *)},
     BlockRandom[SeedRandom[42, Method -> "MersenneTwister"]; (* for reproducibility *)
                 pts = Table[With[{t = RandomReal[]}, (* hint: derive the inverse CDF *)
                                  Sqrt[(t Sinh[r/2]^2)/(1 + t Sinh[r/2]^2)]]
                                  Normalize[RandomVariate[NormalDistribution[], 2]],
                             {n}]];
                 NearestNeighborGraph[pts, {All, h r}, 
                                      DistanceFunction -> poincareMetric, 
                                      EdgeShapeFunction -> (poincareLine[#1] &),
                                      PlotRange -> 1,
                                      Prolog -> {Directive[Opacity[1/2],
                                                           AbsoluteThickness[1]],
                                                 Circle[]}]]