5
$\begingroup$

I have a weighted graph, for example, a random geometric graph within a square domain $[-1/2,1/2]^2$, with a node fixed at the origin.

How do I use HighlightGraph to show all paths which start at the origin, but have a length (sum of weights along the edges) less than $l$?

It is relatively easy to get the shortest paths to some nodes at bounded graph distance from the origin, but what about the "wetted" region, which includes all paths less than length $l$? AllPaths will take too long, I think, and there are too many to count. You can see in the picture that nodes in the wetter region are blue, but not all edges. I essentially want to know, how do I pick out the edges of the wetted region. Perhaps some use of a line graph?

Attempt:

<< IGraphM`
col1 = Blue;
col2 = Red;
(**Define the functions which produce the graph, and pick out the \
geodesics***)
listnodes[t_, gr_] := Module[{pts, gdm},
  gdm = GraphDistanceMatrix[gr][[All, 1]];
  Position[gdm, _?(t - 0.05 < # < t + 0.05 &)]
  ]
listbacknodes[t_, gr_] := Module[{pts, gdm},
  gdm = GraphDistanceMatrix[gr][[All, 1]];
  Position[gdm, _?(# < t + 0.03 &)]
  ]
col1 = Blue;
col2 = Red;
pth1[x_] := {a1[[x]], 
  Style[VertexList[a1[[x]]][[#]], EdgeForm[{col2, Thick}], 
     FaceForm[Darker@col2]] & /@ Range[1, Length@VertexList[a1[[x]]]],
   Style[EdgeList[a1[[x]]][[#]], col2, Thickness[0.007]] & /@ 
   Range[1, Length@EdgeList[a1[[x]]]]}
pth2[x_] := {a2[[x]], 
  Style[VertexList[a2[[x]]][[#]], EdgeForm[{col1, Thin}], 
     FaceForm[col1]] & /@ Range[1, Length@VertexList[a2[[x]]]], 
  Style[EdgeList[a2[[x]]][[#]], col1, Thickness[0.003]] & /@ 
   Range[1, Length@EdgeList[a2[[x]]]]}
nng1[ww_, hh_, x_] := Module[{},
   w1 = ww;
   h1 = hh;
   width = w1;
   height = h1;
   density = x;
   volume = width*height;
   Npoints = density*volume;
   pts = Table[{RandomReal[{-width/2, width/2}], 
      RandomReal[{height/2, -height/2}]}, {i, 1, Npoints}];
   cp = CirclePoints[width/2, 12];
   pts = Join[cp, pts];
   pts = Flatten[Join[{{{0, 0}}, pts}], 1];
   DelG1 = 
    IGEdgeMap[Apply[EuclideanDistance], 
     EdgeWeight -> IGEdgeVertexProp[VertexCoordinates], 
     NearestNeighborGraph[pts, 7, GraphStyle -> "CoolColor", 
      VertexSize -> {"Scaled", 0.005}, 
      EdgeStyle -> {Thickness[100], Blue}, 
      VertexCoordinates -> pts]];
   DelG1 = 
    AdjacencyGraph[AdjacencyMatrix[DelG1], VertexCoordinates -> pts, 
     GraphStyle -> "CoolColor", VertexSize -> {"Scaled", 0.005}, 
     EdgeStyle -> {Thickness[100], Blue}];
   DelG1 = 
    IGEdgeMap[Apply[EuclideanDistance], 
     EdgeWeight -> IGEdgeVertexProp[VertexCoordinates], DelG1];
   DelG1
   ];
nng2[g_, T_] := Module[{},
   DelG1 = g;
   a1 = PathGraph[FindShortestPath[DelG1, 1, #]] & /@ 
     Flatten[listnodes[T, DelG1]];
   a2 = PathGraph[FindShortestPath[DelG1, 1, #]] & /@ 
     Flatten[listbacknodes[T, DelG1]];
   pnng10 = HighlightGraph[DelG1,
     Join[Flatten[pth2[#] & /@ Range[1, Length@a2], 1], 
      Flatten[pth1[#] & /@ Range[1, Length@a1], 1]], 
     ImageSize -> 200]
   ];
(***Draw a graph, then display the wetted region, and the geodesics \
to the boundary***)
gr1 = nng1[20, 20, 3]
Grid[{{nng2[gr1, 2], nng2[gr1, 4], nng2[gr1, 7], nng2[gr1, 10]}}]

enter image description here

$\endgroup$
  • 2
    $\begingroup$ I had to look up where to get the IGraphM package, so I'm putting that here for other's convenience... Get["https://raw.githubusercontent.com/szhorvat/IGraphM/master/IGInstaller.m"] $\endgroup$ – Josh Bishop Jan 10 at 21:07
  • 1
    $\begingroup$ @Alexander How large is the graph for which you want to do that in the end? $\endgroup$ – Henrik Schumacher Jan 10 at 21:32
  • $\begingroup$ Not large, it is simply for a figure, graphs about the size in the post. And it can take e.g. an hour to produce, no need for speed at all. $\endgroup$ – Alexander Kartun-Giles Jan 10 at 22:26
6
$\begingroup$
i = 1;
d = 8.;

vertices = Random`Private`PositionsOf[
   UnitStep[d - IGDistanceMatrix[gr1, {i}][[1]]],
   1
   ];
edges = With[{u = SparseArray[Partition[vertices, 1] -> 1, {VertexCount[gr1]}]},
   SparseArray[u AdjacencyMatrix[gr1].DiagonalMatrix[u]]["NonzeroPositions"]
   ];
pathfun = FindShortestPath[gr1, 1, All];
paths = pathfun /@ vertices;
pathedges = DeleteDuplicates[Join @@ (Partition[#, 2, 1] & /@ paths)];

All shortest paths to points in the "wetted" region:

HighlightGraph[gr1, {UndirectedEdge @@@ pathedges, vertices}]

enter image description here

All wetted edges:

HighlightGraph[gr1, {UndirectedEdge @@@ edges, vertices}]

enter image description here

This is how to obtain the spanning paths. The code uses that the shortest paths going out of vertex 1 for a tree and that the "boundary vertices" are the leaves of this tree. And the leaves have vertex out degree 0.

deg = VertexOutDegree[Graph[Range[VertexCount[gr1]], DirectedEdge @@@ pathedges]];
spanningpaths = Pick[paths, deg[[paths[[All, -1]]]], 0];
$\endgroup$
  • $\begingroup$ Ideal, thank you. Is it possible to add also another figure with all shortest paths to points only on the "boundary" of the wetted region (i.e. to the wetted nodes at distance about t from the origin)? Do I just change the last arg of FindShortestPath[gr1, 1, All] to the chosen nodes? $\endgroup$ – Alexander Kartun-Giles Jan 10 at 23:22
  • $\begingroup$ Ok that in fact worked. Thanks again. $\endgroup$ – Alexander Kartun-Giles Jan 14 at 14:45
  • 1
    $\begingroup$ You're welcome. $\endgroup$ – Henrik Schumacher Jan 14 at 14:46

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.