Certain search in list
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
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
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.