# Certain search in list

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.

• What have you tried? Where did you find difficulties? Jun 5, 2019 at 17:33

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

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.

• +1 though it's over my understanding. You are a profy in Mathematica! Jun 6, 2019 at 6:51
• Thank you for your explanation. Jun 6, 2019 at 7:06
• Your code eats much memory. For $n=10^4$ I get SystemException["MemoryAllocationFailure"] Jun 6, 2019 at 7:27

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

• Thank you. You are a Mathematica master! +1. A good code is a commented code. Is your code an imrovement of the Anjan's one? Jun 6, 2019 at 6:25
• @user64494, thank you for the upvote. Added comments before the code. As mentioned in the post, this is slightly faster than Anjan's fa for the test setup in Anjan's code.
– kglr
Jun 6, 2019 at 6:40
• Thank you again. Now I understand your idea with LengthWhile. Jun 6, 2019 at 6:43

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

• A good code is a commented code. In order to accept your answer, can you add comments to your code? Jun 5, 2019 at 18:58
• Check the comments I have added. Hope that helps. Jun 5, 2019 at 19:15
• Sorry, I changed my mind for serious reasons. Hope you understand me. Jun 6, 2019 at 15:34

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

• Thank you. This is it. However, it takes 11.1681 s for 1000 elements and crashes my comp for 10^4 ones. I will be waiting some time for another answers before accepting yours. Jun 5, 2019 at 17:40
• There must be a better way. I've tried using Shortest on the pattern search, which would eliminate the need for generating all matches and then grouping and picking the shortest; but I cannot make it work. Here is a discussion on why that could be. Jun 5, 2019 at 17:49
• Can the Compile command be applied to increase effectiveness of your code? Jun 5, 2019 at 18:03
• Thank you.That is too complex for me. BTW, a good code is a commented code. In any case, +1. Jun 5, 2019 at 18:03
• @user64494 I don't think compiling the code will do anything here: the code just glues together various powerful commands like SequencePosition and GroupBy, which are internally compiled already. Jun 5, 2019 at 18:47

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

• Does not directly work with SeedRandom[1234]; LL = RandomReal[{-100, 100}, 20] for me. Jun 5, 2019 at 17:34

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)

• Thank you for your interest to the question and work. However, it seems you don't carefully read the question: positions (indexes) are required ,e.g, {.. ,7,9,{},..}. Also in your example the two last elements should be {},{}}. An optimized code is of interest. I think the answer would be of interest for many Mathematica users. Jun 5, 2019 at 16:03