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

Question

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?

Answer 1

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}

Answer 2

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}}

Transpose[MapThread[Part, {{L1, L2}, Transpose[pos]}]]
   {{{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}}}

Answer 3

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 @ #, 
 Function[x, AdjacencyList[#, x]]/@VertexList[#]}]&@RelationGraph[##], {_,{}}]&;

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

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

Answer 4

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.