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.
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]
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]
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"]
Answered by kglr on December 26, 2020
Get help from others!
Recent Answers
Recent Questions
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP