11

I have a set $S$ of $n$ 2-dimensional points. We can compute a distance matrix (Euclidean distance) for $S$ using say this answer. I wish to form an $n$-vertex graph having the points $S$ as vertices, with an edge between two points if their distance is exactly $d$ (for some fixed $d > 0$). What's an idiomatic way of achieving this?

For example, we could start with the following:

pts = {{0, 0}, {0, 1}, {4, 4}, {0, 2}, {1, 2}}; (* Or whatever *)
distances = With[{tr = Transpose[pts]}, 
  Function[point, Sqrt[Total[(point - tr)^2]]] /@ pts];

Alternatively, we could form all 2-subsets of pts, and compute the Euclidean distance for each. However, I'm a bit stuck as to how to continue without resorting to an explicit loop.

J. M.'s missing motivation
  • 124,525
  • 11
  • 401
  • 574
Juho
  • 1,825
  • 1
  • 18
  • 32

2 Answers2

12

I think you're looking for RelationGraph. It takes a list of objects to treat as vertices and a test function which determines whether two given vertices should be connected by an edge:

pts = {{0, 0}, {0, 1}, {4, 4}, {0, 2}, {1, 2}, {1, 1}};
d = 1;
RelationGraph[EuclideanDistance[#, #2] == 1 &, pts]

enter image description here

As of 10.3 a more idiomatic way to implement the test function would probably be

RelationGraph[EuclideanDistance /* EqualTo[d], pts]

RelationGraph automatically makes the graph undirected if your function happens to return the same thing for both orders of every pair, and a directed graph otherwise. You can enforce either type of graph with the DirectedGraph option (setting it either to True or False).

Martin Ender
  • 8,774
  • 1
  • 34
  • 60
7

For version 9

ngF = With[{v = #, d = #2},  
      AdjacencyGraph[v, Outer[Boole[EuclideanDistance@## == d] &, v, v, 1], ##3]] &;

Using Martin's example, pts = {{0, 0}, {0, 1}, {4, 4}, {0, 2}, {1, 2}, {1, 1}}

ngF[pts, 1, VertexLabels -> "Name", ImagePadding -> 10]

Mathematica graphics

You can also use a combination of DistanceMatrix and Clip to get the desired adjacency matrix:

ngF2 = AdjacencyGraph[#, Clip[DistanceMatrix[#], {1, 1} #2, {0, 0}], ##3] &;

ngF2[pts, 1, VertexSize -> Large, PlotTheme -> "VintageDiagram"]

enter image description here

kglr
  • 394,356
  • 18
  • 477
  • 896