10
$\begingroup$

Suppose I have two lists, say:

A = {1,5,10,200,50,7}
B = {4,3,19,78}

For each element in A, I would like to find the index of the first element in B which exceeds that element, (or 0 if none do) i.e. :

result = {1,3,3,0,4,3}

Clever syntax much appreciated!

Improve this question
$\endgroup$
  • 1
    $\begingroup$ Thanks for all the great suggestions, all helping to educate this newbie in different ways. I ought to have mentioned that my particular need here isn't performance critical and only needed for small lists, but thanks for the answers addressing the general case too. $\endgroup$ – Cuboid Aug 24 '12 at 23:22
7
$\begingroup$

This is a compiled solution that should be very fast.

Clear@firstInstance;
With[{part = Compile`GetElement},
    firstInstance = Compile[{{A, _Integer, 1}, {B, _Integer, 1}},
        Module[{res = Table[0, {Length[A]}], i = 1, j = 1, 
            lenA = Length[A], lenB = Length[B]},
            For[i, i <= lenA, i++,
                While[part[A, i] >= part[B, j], If[j == lenB, j = 0; Break[], j++]];
                res[[i]] = j;
                j = 1;
            ];
            res
        ],
        CompilationTarget -> "C",
        RuntimeOptions -> "Speed"
    ]
]

Use it as firstInstance[A, B]

Improve this answer
$\endgroup$
  • 2
    $\begingroup$ +1. I should now be wary that my monopoly on ugly compiled code has been broken :). $\endgroup$ – Leonid Shifrin Aug 24 '12 at 15:01
  • 1
    $\begingroup$ @LeonidShifrin I watch and learn... and then sneak up from behind! :D $\endgroup$ – rm -rf♦ Aug 24 '12 at 15:06
  • 1
    $\begingroup$ That's what I noticed :). Then, a little bit of advice: ConstantArray is not compilable, use Table instead. $\endgroup$ – Leonid Shifrin Aug 24 '12 at 15:08
  • $\begingroup$ Aha! Thanks, I should've checked the result... it does have MainEvaluate[ Hold[ConstantArray][ I0, I3]] that I should've spotted. $\endgroup$ – rm -rf♦ Aug 24 '12 at 15:12
  • 1
    $\begingroup$ Well, normally this won't affect the performance all that much, depends on the code in question. Usually you can gain a few percent speedup this way, sometimes more. $\endgroup$ – Leonid Shifrin Aug 24 '12 at 15:14
5
$\begingroup$ 
 a = {1, 5, 10, 200, 50, 7};
 b = {4, 3, 19, 78};
 Position[#, -1, 1, 1] & /@ (Sign@(# - b) & /@ a) /. {} -> {0} // Flatten
 (* {1, 3, 3, 0, 4, 3} *)

Update: Per whuber's suggestion, removing out-of-order elements from b, and re-mapping position numbers using a parallel list of position indices:

With[{b0 = FoldList[Max, First@b, Rest@b]},
 indices = Pick[Range@Length@b, MapThread[ Equal, {b, b0}]]; 
 (Position[#, -1, 1, 1] & /@ (Sign@(# - Union@b0) & /@ a) /. {} -> {{0}} // Flatten)
   /.Thread[Range@Length@indices -> indices]]

Few more alternatives for creating indices:

indices2 = Pick[Range@Length@b, Equal @@@ Transpose[{b, b0}]]
(* as suggested by J.M:  *)
indices3=Fold[If[#1 === {}||Last[b[[#1]]] < b[[#2]],Append[#1, #2], #1] &,{}, 
          Range[Length[b]]]
Improve this answer
$\endgroup$
  • $\begingroup$ (+1) This has optimal efficiency O(Length[a] Log[Length[b]]. If you want the ultimate (asymptotic, general purpose) speedup, first pre-process b (with O(Length(b)) effort) to remove out-of-order elements altogether, because they will never be found. Notice in the example, for instance, that the target for the position searches only has to be b0={4,19,78} with the 3 omitted. Easy preprocessing produces this shortened vector along with a parallel list of indexes, {1,3,4}, which will convert indexes into b0 into indexes into b. $\endgroup$ – whuber Aug 24 '12 at 18:44
  • 1
    $\begingroup$ @whuber, great suggestions. I will check if i can incorporate them in the next edit. $\endgroup$ – kglr Aug 24 '12 at 19:38
  • $\begingroup$ FWIW, Here is my first attempt at the preprocessing, in case it's any use. I'm sure you can do better :-). indexes = Select[Range[Length[b]] (Boole[# > 0] & /@ Differences[FoldList[Max, First[b] - 1, b]]), # > 0 &]; b0 = Union[FoldList[Max, First[b], b]];. I expect Union to be (sub)linear in length[b] because its argument is already sorted. $\endgroup$ – whuber Aug 24 '12 at 19:42
  • $\begingroup$ Another way to do @whuber's suggestion: Fold[If[#1 === {} || Last[b[[#1]]] < b[[#2]], Append[#1, #2], #1] &, {}, Range[Length[b]]]. $\endgroup$ – J. M.'s ennui♦ Aug 24 '12 at 23:35
  • $\begingroup$ @J.M., whuber thank you both. I added few alternatives for creating the index set including your suggestions. $\endgroup$ – kglr Aug 25 '12 at 0:18
2
$\begingroup$

One quick way is :

If[Length[#] == 0, 0, #[[1, 1]]] & /@ (With[{Local = #}, 
 Position[B, _?(# > Local &)]] & /@ A)

Another using Mr.Wizard's suggestion :

Flatten[If[Or @@ # == False, 0, 
Position[#, True, 1, 
 1]] & /@ (With[{Local = #}, Thread[B > Local]] & /@ A)]
Improve this answer
$\endgroup$
  • $\begingroup$ Excellent, much appreciated. $\endgroup$ – Cuboid Aug 24 '12 at 12:35
  • $\begingroup$ It would be better to use the fourth argument of Position to short-circuit the search on the first find. $\endgroup$ – Mr.Wizard Aug 24 '12 at 12:43
  • $\begingroup$ @Mr.Wizard Thanks, I had forgotten about it. $\endgroup$ – b.gates.you.know.what Aug 24 '12 at 12:46
2
$\begingroup$

Here's my take:

A = {1, 5, 10, 200, 50, 7};
B = {4, 3, 19, 78};

First[Flatten[Position[B - #, _?Positive, 1, 1]] /. {} -> {0}] & /@ A
    {1, 3, 3, 0, 4, 3}
Improve this answer
$\endgroup$
2
$\begingroup$ 
a = {1, 5, 10, 200, 50, 7};
b = {4, 3, 19, 78};

Mod[
  1 + Table[LengthWhile[b, # <= i &], {i, a}],
  Length@b + 1
]

 {1, 3, 3, 0, 4, 3}

Here is a first attempt to create an efficient solution for long b lists.

I decided to experiment with something I'm not really comfortable with, but Leonid mentioned once: using a side-effect in PatternTest. It strikes me as quite obfuscated but maybe that is only because I don't expect it.

  untilLarger[a_, b_] :=
    Module[{dat, min, max, f, test, m = -∞},
      test[x_] /; x > m := (Sow[m = x]; True);
      dat = Join @@@ Reap[Position[b, _?test]]\[Transpose];
      {min, max} = dat[[{1, -1}, 2]];
      f[n_] /; n < min = 1;
      f[n_] /; n >= max = 0;
      f[n_] := Cases[dat, {y_, x_} /; x > n, 1, 1][[1, 1]];
      f /@ a
    ]

untilLarger[a, b]

 {1, 3, 3, 0, 4, 3}
Improve this answer
$\endgroup$
  • $\begingroup$ +1. We were obviously thinking along the same direction. $\endgroup$ – Leonid Shifrin Aug 24 '12 at 12:51
  • 1
    $\begingroup$ Your second solution doesn't give the right result. For example, try with {a, b} = {{8, 2, 17, 4, 6, 6, 4, 6, 4, 2}, {5, 6, 4, 9, 10, 9, 8, 0, 3, 5}} and manually work out the answer for the fifth element in a. I believe this is fixed by checking for >= instead of >. However, making this change leads to other issues with duplicates in longer lists and Interpolation complains. For an example of a case where Interpolation fails, try: SeedRandom[1234]; X = RandomInteger[{0, 20}, 10^3]; Y = RandomInteger[{0, 10}, 10^6]; $\endgroup$ – rm -rf♦ Aug 24 '12 at 15:25
  • $\begingroup$ @R.M I rewrote the second method to use Cases instead of Interpolation as I got the intervals wrong with the latter. Please tell me if it works correctly now. $\endgroup$ – Mr.Wizard Aug 24 '12 at 21:29
  • $\begingroup$ It does. Both our solutions have different limiting factors. Yours is limited by the length of b, whereas mine is limited by that of a. I'm still surprised that it is as fast as it is, what with the Apply, Position, Reap/Sow and Cases... $\endgroup$ – rm -rf♦ Aug 24 '12 at 23:54
0
$\begingroup$

FirstPosition (for versions 10.2+)

FirstPosition[UnitStep[B - #], 1, 0 &][[1]] & /@ A

{1, 3, 3, 0, 4, 3}

FirstPosition[B, _?(Function[t, # <= t]), 0 &][[1]] & /@ A

{1, 3, 3, 0, 4, 3}

Improve this answer
$\endgroup$
0
$\begingroup$

The only relevant elements of B are those that remain when taking the largest monotonous subsequence. Below which is a list containing the positions of the elements of that subsequence.

With[{which = Pick[#, Positive[Append[Differences[#], 1]]] &[Ordering[B]]},
 With[{sz1 = Length[A], sz2 = Length[which]},
  With[{ord = TakeList[Ordering[Ordering[Join[A, B[[which]]]]], {sz1, sz2}]},
   With[{counts = Differences[Prepend[Last[ord], 0]]},
    PadRight[Join @@ MapThread[ConstantArray, {which, counts}], sz1 + sz2][[First[ord]]]]]]]

{1, 3, 3, 0, 4, 3}

If B contains duplicates then which contains the position of all occurences, so the correctness is a bit subtle in that case. It is the order of the arguments of Join that ensures it.

Improve this answer
$\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.