6
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ What have you tried? Where did you find difficulties? $\endgroup$ – David G. Stork Jun 5 at 17:33
4
$\begingroup$

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.

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

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

$\endgroup$
  • $\begingroup$ 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? $\endgroup$ – user64494 Jun 6 at 6:25
  • $\begingroup$ @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. $\endgroup$ – kglr Jun 6 at 6:40
  • $\begingroup$ Thank you again. Now I understand your idea with LengthWhile. $\endgroup$ – user64494 Jun 6 at 6:43
4
$\begingroup$

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

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

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

$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – user64494 Jun 5 at 17:40
  • $\begingroup$ 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. $\endgroup$ – Roman Jun 5 at 17:49
  • $\begingroup$ Can the Compile command be applied to increase effectiveness of your code? $\endgroup$ – user64494 Jun 5 at 18:03
  • $\begingroup$ Thank you.That is too complex for me. BTW, a good code is a commented code. In any case, +1. $\endgroup$ – user64494 Jun 5 at 18:03
  • $\begingroup$ @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. $\endgroup$ – Roman Jun 5 at 18:47
1
$\begingroup$

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

$\endgroup$
  • 1
    $\begingroup$ Does not directly work with SeedRandom[1234]; LL = RandomReal[{-100, 100}, 20] for me. $\endgroup$ – user64494 Jun 5 at 17:34
0
$\begingroup$

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)

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – user64494 Jun 5 at 16:03

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.