# Finding a mapping between elements in two lists that satisfy some criterion (such as being less than threshold Euclidean distance apart)?

I have two lists of $d$-dimensional coordinates, for example setting $d=3$ we might write:

L1 = {{1,2,3},{4,5,6},{7,8,9},{999,999,193}}
L2 = {{80,-10,-12},{1.1,2.4,3.1},{6.99,8.0435,8.999},{4,5.02,6.02}}


Here, some of the elements in $L_2$ are just the elements in $L_1$ perturbed in 3-space by some small amount (a MSD $\leq 0.5$), with the mapping $(1,2,3) \to (2,4,3)$ and where the coordinates at positions four in $L_1$ and one in $L_2$ do not having a mapping (i.e. there's not necessarily a bijection for the lists).

Is there a simple "one-liner" in Mathematica 9 that allows us to compare two lists and return a list of points that satisfy some mapping criterion, e.g. EuclideanDistance in the above example?

Update - For the above example, setting the EuclideanDistance to $R=1$ we'd specifically like to output:

{{{1,2,3},{1.1,2.4,3.1}},{{4,5,6},{4,5.02,6.02}},{{7,8,9},{6.99,8.0435,8.999}}}

(Elements can be in whatever order.)

Could we do this for a set of more than two lists?

I will check that EuclideanDistance < 10 and show those pair of elements.

If you need every element of L1 with every element of L2 check:

dat = Select[Flatten[Outer[{#1, #2} &, L1, L2, 1], 1], EuclideanDistance @@ # < 10 &]


{{{1, 2, 3}, {1.1, 2.4, 3.1}}, {{1, 2, 3}, {4, 5.02, 6.02}}, {{4, 5, 6}, {1.1, 2.4, 3.1}}, {{4, 5, 6}, {6.99, 8.0435, 8.999}}, {{4, 5, 6}, {4, 5.02, 6.02}}, {{7, 8, 9}, {6.99, 8.0435, 8.999}}, {{7, 8, 9}, {4, 5.02, 6.02}}}

Verify:

EuclideanDistance @@@ dat


{0.424264, 5.21927, 4.85592, 5.21507, 0.0282843, 0.0446458, 5.17308}

You can even visualize with a graph the pair relations:

Graph[L1~Join~L2, Rule @@@ flt, VertexLabels -> "Name"]


If you need corresponding pairs check:

Select[Transpose[{L1, L2}], EuclideanDistance @@ # < 10 &]
{{{4, 5, 6}, {1.1, 2.4, 3.1}}, {{7, 8, 9}, {6.99, 8.0435, 8.999}}}


Verify:

EuclideanDistance @@@ %
{4.85592, 0.0446458}

• What? No ear sightings through the head? -1 then Commented Jun 27, 2013 at 3:25
• @belisarius I don't quite understand? Commented Jun 27, 2013 at 3:27
• @belisarius Uncompress["1:eJxTTMoPCmZmYGCw1tUEABDnAiw="] Commented Jun 27, 2013 at 3:29
• @FlavorOfLife He is joking (or is he?..). Cheerfully referring to this ;-) Commented Jun 27, 2013 at 3:31
• @VitaliyKaurov Hmm, why does it miss some of the mappings? Specifically {1,2,3} --> {1.1,2.4,3.1}, and setting the EuclideanDistance to 0.5, it also misses {4, 5, 6} --> {4, 5.02, 6.02}? Commented Jun 27, 2013 at 3:43

These days, I would use DistanceMatrix[]:

L1 = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}, {999, 999, 193}};
L2 = {{80, -10, -12}, {1.1, 2.4, 3.1}, {6.99, 8.0435, 8.999}, {4, 5.02, 6.02}};

pos = Position[DistanceMatrix[L1, L2], x_ /; x < 1, {2}]
{{1, 2}, {2, 4}, {3, 3}}

{{{1, 2, 3}, {1.1, 2.4, 3.1}}, {{4, 5, 6}, {4, 5.02, 6.02}},
{{7, 8, 9}, {6.99, 8.0435, 8.999}}}


In versions 10.2+, you can use RelationGraph:

L1 = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}, {999, 999, 193}};
L2 = {{80, -10, -12}, {1.1, 2.4, 3.1}, {6.99, 8.0435, 8.999}, {4, 5.02, 6.02}};

rg1 = RelationGraph[EuclideanDistance @## < 1 &, L1, L2]


rg2 = RelationGraph[EuclideanDistance @## < 10 &, L1, L2]


oneliner = DeleteCases[Transpose[{VertexList @ #,

oneliner[EuclideanDistance @## < 1 &, L1, L2]// Grid[#, Dividers -> All]&


oneliner[EuclideanDistance @## < 10 &, L1, L2]// Grid[#, Dividers -> All]&


• +1, but which method is more computationally efficient? Commented Oct 1, 2017 at 4:21
• @Alexey, I am afraid not this one:) Thank you for the vote.
– kglr
Commented Oct 1, 2017 at 4:35

Here is a Nearest approach to your question:

nf = Nearest[L1 -> "Index"];

Cases[
SplitBy[Sort @ Thread[{nf[Join[L1, L2], {1, 1}], Join[L1, L2]}], First],
x:{{{_Integer}, _}, __} :> x[[All,2]]
]


{{{1, 2, 3}, {1.1, 2.4, 3.1}}, {{4, 5, 6}, {4, 5.02, 6.02}}, {{6.99, 8.0435, 8.999}, {7, 8, 9}}}

You asked about a solution when there are more than 2 lists. In this case, another idea using Nearest is to combine the lists, and then search for all elements within distance 1 of each member:

With[{all = Join[L1, L2]},
clusters = DeleteDuplicates[
Sort /@ Nearest[all -> "Index", all, {All, 1}]
];
all[[#]]& /@ clusters
]


{{{1, 2, 3}, {1.1, 2.4, 3.1}}, {{4, 5, 6}, {4, 5.02, 6.02}}, {{7, 8, 9}, {6.99, 8.0435, 8.999}}, {{999, 999, 193}}, {{80, -10, -12}}}

(Note that I didn't bother pruning singleton clusters above). The problem with the above approach is that clusters might need to be merged, reflecting the fact that the pairwise distance predicate is not transitive, i.e., $|p_1 - p_2| < 1$ and $|p_2 - p_3|<1$ does not imply that $|p_1-p_3|<1$. You will need to provide more information if merging is needed.

These approaches using Nearest should be much faster than alternatives using Outer, RelationGraph or DistanceMatrix. For instance:

SeedRandom[68]
data = RandomReal[100, {10000, 3}];
clusters = DeleteDuplicates[Sort/@Nearest[data -> "Index", data, {All, 1}]];//AbsoluteTiming


{0.012938, Null}

I chose a particular SeedRandom and data range so that the clusters are all independent:

Length @ Flatten @ clusters


10000

For smaller data ranges, you will get clusters that aren't independent.