Certain search in list

Question

A list $LL$ of $n$ real numbers is given. For each element $e$ of $LL$ to find the position of the closest to the right element of $LL$ which is at least twice bigger than $e$ and return it. If such element does not exist, then {} should be returned.

How to program that in an optimal way? My search in list-manipulation tagged questions brings nothing and I am not strong in programming so I ask it here.

Answer 1

For an arbitrary list we can find the first position of an element that exceed twice the first element using LengthWhile. The helper function twicePos finds this position. The function fk, uses this helper function for each element e in the input list to find the required position (if any) in the sublist to the right of e and add it to the position of e:

ClearAll[twicePos, fk]
twicePos[x_] := LengthWhile[x, 2 First[x] >= # &] /. Length[x] -> {}
fk = Table[i + twicePos[#[[i ;;]]], {i, Length@#}] &;


SeedRandom[1234]
n = 10;
list = RandomReal[{-100, 100}, n];

fk[list]

{{}, 6, 4, 6, 6, {}, 10, 10, 10, {}}

This is slightly faster than Anjan's fa:

SeedRandom[1234]
n = 1000;
list = RandomReal[{-100, 100}, n];

res1 = fk[list]; // AbsoluteTiming // First

0.14639

res2 = fa[list]; // AbsoluteTiming // First

0.177977

res1 == res2

True

Answer 2

This answer is faster than @Roman's by at least a magnitude.

fa[l_] := Module[{twiceSelect, pos, lDuplicate = l, outputList = {}},

     (*Creates an association with positions as values*)
     (*pos = First /@ PositionIndex[l];*) (* If there are same elements in the list this would fail*)
      pos = Thread[l->Range[Length[l]]]//Association; (*This is more robust*)

      (*A helper function to select the first element 
        which satisfies the condition that it should be 
        twice than the first element of the list.*)
     twiceSelect[x_] := SelectFirst[Rest[x], # > 2*First[x] &] /. _Missing -> {};

      (*Here for every loop, you apply twiceSelect[], 
        truncate the list, and so on, for Length[l] times*)
      Do[
          AppendTo[outputList, twiceSelect[lDuplicate]];
          lDuplicate = Rest[lDuplicate];,
          Length[l]
        ];

       (*After obtaining all the required elements, replace the
        elements with their corresponsing positions*)
       outputList /. pos
      ]

Test

SeedRandom[1234]
list = RandomReal[{-100, 100}, 10];
fa[list]

{{}, 6, 4, 6, 6, {}, 10, 10, 10, {}}

Timing Comparison

SeedRandom[1234]
list = RandomReal[{-100, 100}, 1000];

fr[LL_]:=Lookup[GroupBy[
   SequencePosition[LL, {e_, ___, f_} /; f >= 2 e, Overlaps -> All], 
  First -> Last, Min], Range[Length[LL]], {}
]; (*Roman's*)

m = fr[list];//AbsoluteTiming
n = fa[list];//AbsoluteTiming
m == n

{4.32954, Null}

{0.122447, Null}

True

Answer 3

Update

If you're going to try to work with lists of length $n$ greater than a few thousand, it doesn't make sense to use Outer to generate an $n \times n$ matrix.

In this case, you should work on one list at a time. For speed reasons, it will be convenient to have a compiled function (from an answer by MichaelE2) to figure out the position of the first non - zero element :

firstnzp = Compile[{{list,_Integer,1}},
    Do[If[list[[i]] != 0, Return[i]], {i,Length@list}],
    RuntimeOptions->"Speed"
];

Then, a function that works on one list at a time is:

twice[ll_] := firstnzp @ UnitStep[Rest[ll] - 2 First[ll]]

Applying this function to suitably restricted subsets of list gives:

fd[ll_] := Replace[
    Table[twice[ll[[i;;]]], {i, Length[ll]}] + Range @ Length @ ll,
    Length @ ll + 1 -> {},
    {1}
]

Comparison:

SeedRandom[1234]
list=RandomReal[{-100,100},10000];

r1 = fa[list]; //AbsoluteTiming
r2 = fd[list]; //AbsoluteTiming

r1 === r2

{64.9011, Null}

{2.05682, Null}

True

Original answer

Here's another approach using Outer to subtract 2 times the element from the rest of the list for each element in the list, and then converting to a SparseArray to take advantage of the nice "MatrixColumns" method. The UnitStep and UpperTriangularize pieces just zero out irrelevant elements:

fc[ll_] := Replace[
    UpperTriangularize[
        SparseArray @ UnitStep @ Outer[Plus,-2ll,ll],
        1
    ]["MatrixColumns"],
    {a_,___}->a,
    {1}
]

Timing comparison:

r1 = fa[list]; //AbsoluteTiming
r2 = fc[list]; //AbsoluteTiming

r1 === r2

{0.143921, Null}

{0.029986, Null}

True

Brief explanation

To see how it works, consider the following short example:

SeedRandom[1]
list = RandomInteger[{-3,10}, 10]

{10, -2, 1, -3, 4, -3, -3, 5, 3, -3}

Let's look at the 3rd element, which is 1. We need to subtract 2 from all of the elements to the right, but I will instead just subtract 2 from all of them (this is the Outer step):

list - 2

{8, -4, -1, -5, 2, -5, -5, 3, 1, -5}

Clearly, any element less than 0 doesn't satisfy the criteria, so use UnitStep to set them to 0, and the others to 1 (the UnitStep step):

UnitStep[list - 2]

{1, 0, 0, 0, 1, 0, 0, 1, 1, 0}

Now, we also need to ignore the first 3 elements, since they aren't to the right of the 3rd element. Let's set them to 0 as well (the UpperTriangularize step):

MapAt[0&, UnitStep[list - 2], 1]

{0, 0, 0, 0, 1, 0, 0, 1, 1, 0}

Finally, we want to find the first nonzero column, which is 5 in this case. This is the "MatrixColumns" step, which returns all nonzero columns for a given row.

Answer 4

Using @MarcoB's example,

SeedRandom[1234];
LL = RandomReal[{-100, 100}, 20]
(*    {75.3217, 4.39285, -82.7553, -24.4174, -97.6711,
       85.4532, 8.75135, -4.13367, -50.9302, 51.9792,
       96.9986, -56.591, -8.19656, 76.9458, 16.7709,
       -47.2054, 83.912, -15.233, 97.4581, 17.5885}    *)

Find the required list: a slow method that uses very powerful operators, in the hope of teaching something to someone:

Lookup[GroupBy[SequencePosition[LL, {e_, ___, f_} /; f >= 2 e, Overlaps -> All],
               First -> Last, Min], Range[Length[LL]], {}]
(*    {{}, 6, 4, 6, 6, {}, 10, 10, 10, {}, {}, 13, 14, {}, 17, 17, {}, 19, {}, {}}    *)

If only there was a FirstSequencePosition command, this would be a lot simpler.

---

commented version of the code

SequencePosition finds all sublists of LL that match the pattern of $\{e, \ldots, f\ge 2e\}$, where the dots stand for zero or more other numbers (a BlankNullSequence ___). The option Overlaps -> All instructs to return all matches: long ones and short ones, even if they overlap:

SequencePosition[LL, {e_, ___, f_} /; f >= 2 e, Overlaps -> All]

{{2, 20}, {2, 19}, {2, 17}, {2, 15}, {2, 14}, {2, 11}, {2, 10}, {2, 6}, {3, 20}, {3, 19}, {3, 18}, {3, 17}, {3, 16}, {3, 15}, {3, 14}, {3, 13}, {3, 12}, {3, 11}, {3, 10}, {3, 9}, {3, 8}, {3, 7}, {3, 6}, {3, 5}, {3, 4}, {4, 20}, {4, 19}, {4, 18}, {4, 17}, {4, 16}, {4, 15}, {4, 14}, {4, 13}, {4, 11}, {4, 10}, {4, 8}, {4, 7}, {4, 6}, {5, 20}, {5, 19}, {5, 18}, {5, 17}, {5, 16}, {5, 15}, {5, 14}, {5, 13}, {5, 12}, {5, 11}, {5, 10}, {5, 9}, {5, 8}, {5, 7}, {5, 6}, {7, 20}, {7, 19}, {7, 17}, {7, 14}, {7, 11}, {7, 10}, {8, 20}, {8, 19}, {8, 17}, {8, 15}, {8, 14}, {8, 13}, {8, 11}, {8, 10}, {9, 20}, {9, 19}, {9, 18}, {9, 17}, {9, 16}, {9, 15}, {9, 14}, {9, 13}, {9, 12}, {9, 11}, {9, 10}, {12, 20}, {12, 19}, {12, 18}, {12, 17}, {12, 16}, {12, 15}, {12, 14}, {12, 13}, {13, 20}, {13, 19}, {13, 18}, {13, 17}, {13, 15}, {13, 14}, {15, 19}, {15, 17}, {16, 20}, {16, 19}, {16, 18}, {16, 17}, {18, 20}, {18, 19}}

Each one of these matches is returned as a pair of indices, giving the start and end position of the match in the original list LL.

We GroupBy these matches by start position (First) and keep only the end positions (Last); then for each of the found groups we calculate the minimum (Min) of these end positions, which gives us the nearest-to-the-right end position satisfying the pattern constraint:

GroupBy[%, First -> Last, Min]

<|2 -> 6, 3 -> 4, 4 -> 6, 5 -> 6, 7 -> 10, 8 -> 10, 9 -> 10, 12 -> 13, 13 -> 14, 15 -> 17, 16 -> 17, 18 -> 19|>

This output is in the form of an Association. To continue, we Lookup each start position (Range[Length[LL]]) in this association to find the smallest end position. If none is found, return {}:

Lookup[%, Range[Length[LL]], {}]

{{}, 6, 4, 6, 6, {}, 10, 10, 10, {}, {}, 13, 14, {}, 17, 17, {}, 19, {}, {}}

Answer 5

I am posting a different approach after explanation from the OP:

ll = Range[20]

{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20}

Table[
  FirstPosition[ll[[i + 1 ;;]], _?(# >= 2 ll[[i]] &), {}, 1] + i,
  {i, Length[ll]}
] /. {a_} :> a

{2, 4, 6, 8, 10, 12, 14, 16, 18, 20, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}}

Answer 6

Let's generate a list to work with:

SeedRandom[1234]
ll = RandomReal[{-100, 100}, 20]

{75.3217, 4.39285, -82.7553, -24.4174, -97.6711, 85.4532, 8.75135, -4.13367, -50.9302, 51.9792, 96.9986, -56.591, -8.19656, 76.9458, 16.7709, -47.2054, 83.912, -15.233, 97.4581, 17.5885}

We are then going to generate a series of sublists, dropping the first $i$ elements of list; in this case we would drop the first, then the first two, then the first three elements, etc.

Over this list of lists, we map a selector function that selects the first-encountered element from each sublist that is at least twice as large as the first element of that sublist. The search naturally proceeds to the right of the first element. This is accomplished using SelectFirst, an appropriate criterion, and a default return of {} in case no such element is found.

Map[
  Function[{list}, SelectFirst[list, # >= 2 First[list] &, {}]],
  Table[ll[[i ;;]], {i, Length[ll] - 1}]
]

{{}, 85.4532, -82.7553, -24.4174, -97.6711, {}, 51.9792, -4.13367, -50.9302, {}, {}, -56.591, -8.19656, {}, 83.912, -47.2054, {}, -15.233, {}}

You can confirm by inspection that this seems to return what you wanted.

---

Note that in this case we cannot directly use the operator form of SelectFirst, although it would make for more legible code, because that form does not allow us to specify a custom not-found response)