Fast Selections Testing on Inequality

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.

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}

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.

• Can you test Last[Pick[list[[All, 2]], UnitStep[list[[All, 1]] - value], 0]]? Oct 15, 2015 at 10:54
• That's interesting ... Oct 15, 2015 at 10:56
• Thanks J.M. You should post that as an answer. Oct 15, 2015 at 12:02
• 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. Oct 15, 2015 at 12:03
• 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. Oct 15, 2015 at 14:06

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


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


• 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. Oct 15, 2015 at 15:03
• @LeonidShifrin It's mostly calling overhead Oct 15, 2015 at 15:06

This seems to be reasonably fast:

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

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


{"r", "t"}

• Timing result is about 3 seconds on Mathematica 10, twice as fast as the method using Select. Oct 15, 2015 at 14:25

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
`