14
$\begingroup$

Is there a functional idiom for fast selections testing on inequality?

For example, finding values from list a & b where the key is less than or equal to a value, in this case 4 or 9.

enter image description here

An inefficient method is to test on inequality.

a = {{1, "r"}, {5, "s"}, {7, "t"}};
b = {{2, "u"}, {10, "v"}};

f[list_, value_] := Module[{found},
  found = Select[list, First[#] <= value &];
  found[[-1, 2]]]

{f[a, #] & /@ {4, 9}, f[b, #] & /@ {4, 9}}

{{r, t}, {u, u}}

More efficient is to fill the lists and make a fast selection.

fill[list_, maxvalue_] := Module[{counter = 0, test},
  test[_] := False;
  Scan[(test[#] = True) &, First /@ list];
  range = Range[list[[1, 1]], maxvalue];
  full = If[test[#], list[[++counter]], list[[counter]]] & /@ range;
  full[[All, 1]] = range;
  full]

a2 = fill[a, 11];
b2 = fill[b, 11];

g[list_, input_] := Module[{test, sowMatches},
  Scan[(test[#] := True) &, input];
  sowMatches[x_ /; test[x[[1]]]] := Sow[x, x[[1]]];
  Last /@ Flatten[Last@Reap[Scan[sowMatches, list], input], 2]]

{g[a2, {4, 9}], g[b2, {4, 9}]}

{{r, t}, {u, u}}

Demonstrating timing.

Edit - Now including J.M.'s function as h[].

h[list_, value_] := Last@Pick[list[[All, 2]], UnitStep[list[[All, 1]] - value - 1], 0]

Timing code

a = {#, #} & /@ Sort@RandomSample[Range[100000], 500];
b = {#, #} & /@ Sort@RandomSample[Range[100000], 500];
minimuminput = Max[a[[1, 1]], b[[1, 1]]];
input = Sort[RandomSample[Range[100000], 10000] + minimuminput];

timefa = First@Timing[fa = f[a, #] & /@ input];
timefb = First@Timing[fb = f[b, #] & /@ input];

timega = First@Timing[ga = g[fill[a, Max@input], input]];
timegb = First@Timing[gb = g[fill[b, Max@input], input]];

timeha = First@Timing[ha = h[a, #] & /@ input];
timehb = First@Timing[hb = h[b, #] & /@ input];

Print["Results are the same? ", {fa == ga == ha, fb == gb == hb}

TableForm[{{timefa, timega, timeha}, {timefb, timegb, timehb}},
 TableHeadings -> {{"a", "b"}, {"f[]", "g[]", "h[]"}}]

Results are the same? {True, True}

enter image description here

So pre-filling and fast selection is much faster than direct inequality testing on large lists. However, filling the list could be impractical for large data sets. Can anyone suggest an efficient method?

Edit - J.M.'s elegant solution performs very impressively.

$\endgroup$
  • 2
    $\begingroup$ Can you test Last[Pick[list[[All, 2]], UnitStep[list[[All, 1]] - value], 0]]? $\endgroup$ – J. M. will be back soon Oct 15 '15 at 10:54
  • $\begingroup$ That's interesting ... $\endgroup$ – Chris Degnen Oct 15 '15 at 10:56
  • $\begingroup$ Thanks J.M. You should post that as an answer. $\endgroup$ – Chris Degnen Oct 15 '15 at 12:02
  • $\begingroup$ If it suits your needs, you could write an answer based on my suggestion; I see that you did a few adjustments that I did not take into account. $\endgroup$ – J. M. will be back soon Oct 15 '15 at 12:03
  • $\begingroup$ If your keys in the list are sorted, then the fastest would be a binary search. In that case, have a look here, you may adopt e.g. my solution (based on binary search) to your case rather easily. $\endgroup$ – Leonid Shifrin Oct 15 '15 at 14:06
6
$\begingroup$

J.M.'s solution, with '-1' added to select on <= rather than <.

h[list_, value_] := Last[Pick[list[[All, 2]],
   UnitStep[list[[All, 1]] - value - 1], 0]]
$\endgroup$
4
$\begingroup$

As the list is sorted you can perform a binary search in $O(\log(n))$

<< Combinatorica`
SeedRandom[42];
a = {#, #} & /@ Sort@RandomSample[Range[100000], 500];

s[l_, k_] := l[[Floor@BinarySearch[l[[All, 1]], k], 2]]
s[a, 2000]

(* 1920 *)

a[[All, 1]][[1 ;; 10]]
(*{387, 1339, 1344, 1558, 1653, 1881, 1920, 2119, 2170, 2206}*)

Or the faster Leonid's version

Clear[sLeonid];
sLeonid = 
  Compile[{{lst, _Real, 2}, {pt, _Real}}, 
   Module[{pos = -1, x = lst[[All, 1]], y = lst[[All, 2]], n0 = 1, 
     n1 = Length[lst], m = 0}, While[n0 <= n1, m = Floor[(n0 + n1)/2];
     If[x[[m]] == pt, While[x[[m]] == pt && m < Length[lst], m++];
      pos = If[m == Length[lst], m, m - 1];
      Break[];];
     If[x[[m]] < pt, n0 = m + 1, n1 = m - 1]];
    If[pos == -1, pos = If[x[[m]] < pt, m, m - 1]];
    Which[pos == 0, y[[1]], pos == Length[x], y[[-1]], True, 
     y[[pos]]]], CompilationTarget -> "C"];

 sLeonid[a, 2000]
(* 1920 *)

Some timings:

h[list_, value_] := Last[Pick[list[[All, 2]], UnitStep[list[[All, 1]] - value - 1], 0]]

a = {#, #} & /@ Sort@RandomSample[Range[100000], 5000];
b = {#, #} & /@ Sort@RandomSample[Range[100000], 5000];
minimuminput = Max[a[[1, 1]], b[[1, 1]]];
input = Sort[RandomSample[Range[100000], 10000] + minimuminput];

timeLa = First@Timing[La = sLeonid[a, #] & /@ input];
timeLb = First@Timing[Lb = sLeonid[b, #] & /@ input];

timeha = First@Timing[ha = h[a, #] & /@ input];
timehb = First@Timing[hb = h[b, #] & /@ input];

Print["Results are the same? ", {La == ha, Lb == hb} ];
TableForm[{{timeLa, timeha}, {timeLb, timehb}}, 
          TableHeadings -> {{"a", "b"}, {"Leonid's", "h[]"}}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ I am actually very surprised that the binary search version is so slow. Perhaps the lists are not long enough. No time to look deeper right now. +1, of course. $\endgroup$ – Leonid Shifrin Oct 15 '15 at 15:03
  • $\begingroup$ @LeonidShifrin It's mostly calling overhead $\endgroup$ – Dr. belisarius Oct 15 '15 at 15:06
3
$\begingroup$

This seems to be reasonably fast:

a = {{1, "r"}, {5, "s"}, {7, "t"}};

FirstCase[Reverse @ a, {x_ /; x <= #, y_} :> y] & /@ {4, 9}

{"r", "t"}

$\endgroup$
  • $\begingroup$ Timing result is about 3 seconds on Mathematica 10, twice as fast as the method using Select. $\endgroup$ – Chris Degnen Oct 15 '15 at 14:25
2
$\begingroup$

This isn't anywhere near as fast as J.M.'s solution, but appears slightly faster than the best of belisarius' solutions, although the difference is small enough that it could be because of CPU speed difference.

h[data_, max_] :=
  Module[{keys, vals},
   {keys, vals} = Transpose[data];
   vals[[Position[keys, _?(# <= max &)][[-1, 1]]]]]

a = {{1, "r"}, {5, "s"}, {7, "t"}};
b = {{2, "u"}, {10, "v"}};
Outer[h, {a, b}, {4, 9}, 1]
{{"r", "t"}, {"u", "u"}}
SeedRandom[42]; 
aa = {#, #} & /@ Sort @ RandomSample[Range[100000], 500];
input = Sort[RandomSample[Range[100000], 10000] + aa[[1, 1]]];

First @ Timing[h[a, #] & /@ input;]
4.55674

Here is J.M.'s solution on my system for comparison.

jm[data_, max_] := 
  Last[Pick[data[[All, 2]], UnitStep[data[[All, 1]] - max - 1], 0]]
First @ Timing[jm[aa, #] & /@ input;]
0.338045
$\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.