3
$\begingroup$

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?

$\endgroup$
4
$\begingroup$

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"]

enter image description here

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}
$\endgroup$
10
  • $\begingroup$ What? No ear sightings through the head? -1 then $\endgroup$ – Dr. belisarius Jun 27 '13 at 3:25
  • $\begingroup$ @belisarius I don't quite understand? $\endgroup$ – FlavorOfLife Jun 27 '13 at 3:27
  • 1
    $\begingroup$ @belisarius Uncompress["1:eJxTTMoPCmZmYGCw1tUEABDnAiw="] $\endgroup$ – Vitaliy Kaurov Jun 27 '13 at 3:29
  • 1
    $\begingroup$ @FlavorOfLife He is joking (or is he?..). Cheerfully referring to this ;-) $\endgroup$ – Vitaliy Kaurov Jun 27 '13 at 3:31
  • $\begingroup$ @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}? $\endgroup$ – FlavorOfLife Jun 27 '13 at 3:43
2
$\begingroup$

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}}}
$\endgroup$
1
$\begingroup$

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]

enter image description here

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

enter image description here

oneliner = DeleteCases[Transpose[{VertexList @ #, 
 Function[x, AdjacencyList[#, x]]/@VertexList[#]}]&@RelationGraph[##], {_,{}}]&;

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

enter image description here

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

enter image description here

$\endgroup$
2
  • $\begingroup$ +1, but which method is more computationally efficient? $\endgroup$ – Alexey Popkov Oct 1 '17 at 4:21
  • 1
    $\begingroup$ @Alexey, I am afraid not this one:) Thank you for the vote. $\endgroup$ – kglr Oct 1 '17 at 4:35
1
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.