# How to remove multiplicities from for a list in way meeting special criteria

I have a list of pairs, tabul, which has the property that the second element of each pair is also an element in my list data. I want to reduce tabul so that has the same length as data and meets the following criteria:

1. each element of data is contained in tabul exactly once
2. in the retained pairs, Abs[x - y] is minimized for each y ∈ data

The lists tabul and data are given here.

 data = {-1011.7, -386.7, 93.3, 345.3, 345.3, 1688.3};
tabul =
{{-376.0786041017524, -386.7}, -410.4424666210672,-386.7},
{-1028.4025915824375, -1011.7}, {-399.10959105211384,-386.7},
{-441.0293595101775, -386.7}, {325.51004782358063,345.3},
{291.1461853042659,345.3},{-368.73370811516816, -386.7},
{1697.3159559387486, 1688.3}, {43.36333751931454, 93.3}};


The result I want is here.

result =
{{-376.0786041017524, -386.7}, {-1028.4025915824375,-1011.7},
{325.51004782358063, 345.3}, {291.1461853042659, 345.3},
{1697.3159559387486, 1688.3}, {43.36333751931454,93.3}}.


My code follows, but it does not produce the desired result.

pos = Flatten[Map[Position[data, #] &, tabul[[All, 2]]]]
mod = Commonest[pos, 1]
cp = data[[mod]][[1]]
sel = Cases[tabul, {_, cp}]
DeleteDuplicates[
tabul,
sel[[All, #1]] - sel[[All, #2]] & > Min[Abs[sel[[All, 1]] - sel[[All, 2]]]]]

• This seems to to the trick: Module[{mark}, Flatten[Take[#, Count[#, {mark, _}]] & /@ (SortBy[#, Abs[Differences@#] &] & /@ GatherBy[Join[#2, {mark, #} & /@ #1], Last]), 1]] &[data, tabul]
– ciao
Commented Jun 28, 2015 at 22:31

data = {-1011.7, -386.7, 93.3, 345.3, 345.3, 1688.3};
tabul = {{-376.079, -386.7}, {-410.442, -386.7},
{-1028.4, -1011.7}, {-399.11, -386.7},
{-441.029, -386.7}, {325.51, 345.3},
{291.146, 345.3}, {-368.734, -386.7},
{1697.32, 1688.3}, {43.3633, 93.3}};


The strategy is to first group the pairs in tabul by their 2-nd element and sort the each of the groups by Abs[x - y].

groups =
SortBy[
SortBy[Abs[#[[1]] - #[[2]]] &] /@ GatherBy[tabul, Last],
Last /* First]

{{{-1028.4, -1011.7}},
{{-376.079, -386.7}, {-399.11, -386.7}, {-368.734, -386.7}, {-410.442, -386.7}, {-441.029, -386.7}},
{{43.3633, 93.3}},
{{325.51, 345.3}, {291.146, 345.3}},
{{1697.32, 1688.3}}}


The second stop is to get a list of the multiplicities.

m = Last /@ Sort @ Tally[data]

{1, 1, 1, 2, 1}


The third step is to extract the pairs that are to be retained

Flatten[MapThread[Take, {groups, m}], 1]

{{-1028.4, -1011.7}, {-376.079, -386.7}, {43.3633, 93.3},
{325.51, 345.3}, {291.146, 345.3}, {1697.32, 1688.3}}

• This does not give the correct result.
– ciao
Commented Jun 28, 2015 at 22:10
• @ciao. You're right. I'll see if I can fix it. Commented Jun 28, 2015 at 22:12
• @ciao. I think it's fixed. Commented Jun 28, 2015 at 22:58
• Beats me - I've still not re-installed 10 (waiting for fixes), but the order does not match OP, I assume that matters... perhaps not. But +1 for clever.
– ciao
Commented Jun 28, 2015 at 23:09
• @ciao. You're right about order. I presume it does not matter. My result is nicely sorted. Personally, I would prefer that, but it is certainly the OP's call, and I hope he/she will let us know. Commented Jun 28, 2015 at 23:17

Exactly same approach than @m_goldberg but using GroupBy and MinimalBy :

Values@GroupBy[tabul, Last, MinimalBy[#, Abs[Differences[#]] &,
Count[data, Last@First@#]] &]


{{-376.079, -386.7}}, {{-1028.4, -1011.7}}, {{325.51, 345.3}, {291.146, 345.3}}, {{1697.32, 1688.3}}, {{43.3633, 93.3}}}

• +1 Nice use of some the new functions introduced in V10 Commented Jun 29, 2015 at 13:41