TransWikia.com

Constructing a graph from a distance matrix

Mathematica Asked by Juho on December 26, 2020

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.

2 Answers

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).

Correct answer by Martin Ender on December 26, 2020

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

Answered by kglr on December 26, 2020

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP