2
$\begingroup$

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]]]]]
$\endgroup$
  • $\begingroup$ This seems to to the trick: Module[{mark}, Flatten[Take[#, Count[#, {mark, _}]] & /@ (SortBy[#, Abs[Differences@#] &] & /@ GatherBy[Join[#2, {mark, #} & /@ #1], Last]), 1]] &[data, tabul] $\endgroup$ – ciao Jun 28 '15 at 22:31
3
$\begingroup$
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}}
$\endgroup$
  • $\begingroup$ This does not give the correct result. $\endgroup$ – ciao Jun 28 '15 at 22:10
  • $\begingroup$ @ciao. You're right. I'll see if I can fix it. $\endgroup$ – m_goldberg Jun 28 '15 at 22:12
  • $\begingroup$ @ciao. I think it's fixed. $\endgroup$ – m_goldberg Jun 28 '15 at 22:58
  • $\begingroup$ 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. $\endgroup$ – ciao Jun 28 '15 at 23:09
  • $\begingroup$ @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. $\endgroup$ – m_goldberg Jun 28 '15 at 23:17
2
$\begingroup$

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

$\endgroup$
  • $\begingroup$ +1 Nice use of some the new functions introduced in V10 $\endgroup$ – m_goldberg Jun 29 '15 at 13:41

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.