Relative Neighbourhood Graph
Ad-hoc implementation of Relative Neighborhood Graph (RNG)
Under the heuristic assumption that that each vertex in a RelativeNeighborhoodGraph
will have at most valence 6, this could be a way to exploit Nearest
to compute it:
ClearAll[RelativeNeighborhoodGraph];
RelativeNeighborhoodGraph[pts_?((MatrixQ[#] && Dimensions[#][[2]] == 2) &)] :=
Module[{nf, i, j, p, q, edgelengths, edges},
nf = Nearest[pts -> Automatic];
i = Join @@ Rest[Transpose[nf[pts, {7, ∞}]]];
j = Join @@ ConstantArray[Range[Length[pts]], 6];
edges = DeleteDuplicates[Sort /@ Transpose[{i, j}]];
{i, j} = Transpose[edges];
p = pts[[i]];
q = pts[[j]];
edgelengths = Sqrt[Dot[Subtract[p, q]^2, ConstantArray[1., 2]]];
edges = Pick[
edges,
MapThread[
{x, y, d} \[Function] Length[Intersection[nf[x, {∞, d}], nf[y, {∞, d}]]],
{p, q, edgelengths + 100 $MachineEpsilon}
],
2
];
Graph[Range[Length[pts]], UndirectedEdge @@@ edges, VertexCoordinates -> pts]
]
Usage example:
SeedRandom[20181008];
pts = RandomReal[{-1, 1}, {1000, 2}]
RelativeNeighborhoodGraph[pts]
Implementation of $\beta$-Skeleton for $\beta \geq 1$
The $2$-Skeleton is precisely the RNG. So we can try to compute this one.
The strategy is the same as above: First sieving out a list of edges that a as-small-as-possible superset of the $\beta$-Skeleton's edge list.
For $\beta \geq 1$, we may exploit that the $\beta$-Skeleton is a subgraph of the edge-graph of the Delaunay triangulation. So we may skip the heuristic sieving argument from above and start from the edges of DelaunayMesh[pts]
.
ClearAll[BetaSkeleton];
BetaSkeleton[
pts_?((MatrixQ[#] && Dimensions[#][[2]] == 2) &),
β_ /; β >= 1
] := Module[{nf, i, j, p, q, r, edgelengths, edges},
nf = Nearest[pts -> Automatic];
edges =
MeshCells[DelaunayMesh[pts], 1, "Multicells" -> True][[1, 1]];
{i, j} = Transpose[edges];
p = pts[[i]];
q = pts[[j]];
r = 0.5 β;
edgelengths = Sqrt[Dot[Subtract[p, q]^2, ConstantArray[1., 2]]];
edges =
Pick[edges,
MapThread[
{x, y, d} \[Function] Length[
Intersection[
nf[x + (r - 1) (x - y), {∞, d}],
nf[y + (r - 1) (y - x), {∞, d}]
]
],
{p, q, r (edgelengths + 100 $MachineEpsilon)}
],
2
];
Graph[Range[Length[pts]], UndirectedEdge @@@ edges, VertexCoordinates -> pts]
]
Examples:
BetaSkeleton[pts, 2.0]
BetaSkeleton[pts, 2.5]
IGraph/M now has functions for computing a few types of proximity graphs, including the relative neighbourhood graph and β-skeletons.
IGRelativeNeighborhoodGraph@RandomPoint[Disk[], 1000]
This is still a work-in-progress and performance optimizations, as well as generalizations, are possible in the future.