2
$\begingroup$

I am trying to get the "transversal deviation" of a Euclidean geodesic path in a random geometric graph embedded in a rectangle. An example is shown below, with the path in red joining the two green vertices.

A random geometric graph bounded inside a rectangle, with a Euclidean geodesic highlighted.

The code below simply draws NearNeighbourGraph, setting the option to add edges between the uniformly random points when they are within a unit distance, followed by SetProperty to add edge weights i.e. their Euclidean distance, and then FindShortestPath to find the multi-hop path of least weight between two nodes at fixed distance (the final two elements of v). The max. deviation of the path from the horizontal is then the max of the $y$-components of the vertices on this path.

Clear[n, v, Y, gr, edges, edgelst, vertices, distribution2, data2, K, 
  a, v, rho0, slc, TT, wgr];
rmin = 15.2;
rmax = 15.4;
rho0 = 3;
inc = 1;
steps = (rmax - rmin)/inc;
Ngraphs = 2;
distribution3 = ConstantArray[0, {Ngraphs, Ceiling[steps]}];
For[i = 1, i <= Ceiling[steps], i++,
  \[Rho] = rho0 ;
  r = rmin + (i - 1)*inc;
  For[graphcount = 1, graphcount <= Ngraphs, graphcount++,
   If[Mod[graphcount, 250] == 0, 
    Print["GraphsDone=", 
      graphcount];];(*Change this value to print out 'loading' bar \
with different resolution*)

   n = RandomVariate[PoissonDistribution[1/2 \[Rho] r^2]];
   v = Table[{RandomReal[{-r/2, r/2}], RandomReal[{-r/4, r/4}]}, {k, 
      1, n}];
   v = Append[v, {-r/2, 0}];
   v = Append[v, {r/2, 0}];
   gr = NearestNeighborGraph[v, {All, 1}, VertexCoordinates -> v];
   gr = SetProperty[gr, 
     EdgeWeight -> EuclideanDistance @@@ EdgeList[gr]];
   While[ConnectedGraphQ[gr] == False,
    Clear[n, v, gr];
    n = RandomVariate[PoissonDistribution[\[Rho] r^2]];
    v = Table[{RandomReal[{-r, r}], RandomReal[{-r/4, r/4}]}, {k, 1, 
       n}];
    v = Append[v, {-r, 0}];
    v = Append[v, {r, 0}];
    gr = NearestNeighborGraph[v, {All, 1}, VertexCoordinates -> v];
    gr = SetProperty[gr, 
      EdgeWeight -> EuclideanDistance @@@ EdgeList[gr]];
    ];
   distribution3[[graphcount, i]] = 
    Abs[Max[FindShortestPath[gr, v[[n + 1]], v[[n + 2]]][[All, 
       2]]]];]; Print["Distance ", r, " done"];];
(*For[i=1,i\[LessEqual]Ngraphs,i++,
distribution3[[i,Ceiling[steps]+1]]=rmin+(i-1)*inc;
];*)
X = HighlightGraph[gr,
  {PathGraph[FindShortestPath[gr, v[[n + 1]], v[[n + 2]]], 
    ImageSize -> Large, ImagePadding -> 15]}, 
  GraphHighlightStyle -> "Thick", 
  VertexStyle -> {v[[n + 1]] -> Green, v[[n + 2]] -> Green}]

The difficulty I'm having is that for large graphs, for example where the least-weight path is many "hops" long, this is taking too long to get reliable data on the average deviation, which is hypothesised (in the field of "first passage percolation") to be a power law in the Euclidean separation of the endpoints of the path.

Is there a way to speed it up?

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.