Argmax in a List

Question

I have a sequence of 100 lists. A sample list, list[1], looks like this:

list[1]=Table[{N[i/10], 25 - (i - 2)^2, 25 - (i - 8)^2}, {i, 1, 10}]

{{0.1, 24, -24}, 
 {0.2, 25, -11},
 {0.3, 24, 0},
 {0.4, 21, 9},
 {0.5, 16,16},
 {0.6, 9, 21},
 {0.7, 0, 24},
 {0.8, -11, 25},
 {0.9, -24,24},
 {1., -39, 21}}

I would like to see where the 3rd column, $list[1][[*, 3]]$ is maximized.

The 8th Row in this example. Then I want to note the value of the first column in the 8th row, namely

$list[1][[8,1]]=0.8$.

Then I would like to delete all records where the 1st column is > 0.8, i.e. where

$list[1][[*,1]]>list[1][[8,1]]$ .

In this example, since the numbers are monotonic, that means the last two rows get deleted. I'll be left with:

    {{0.1, 24, -24}, 
 {0.2, 25, -11},
 {0.3, 24, 0},
 {0.4, 21, 9},
 {0.5, 16,16},
 {0.6, 9, 21},
 {0.7, 0, 24},
 {0.8, -11, 25}}

Then, I would like to see where the 2nd column, $list[1][[*, 2]]$ is maximized.

The 2nd Row in this example. Then I want to note the value of the first column in the 2nd row, namely

$list[1][[2,1]]=0.2$.

Then I would like to delete all records where the 1st column is < 0.2, i.e. where

$list[1][[*,1]]<list[1][[2,1]]$ .

In this example, since the numbers are monotonic, that means the first row get deleted. I'll be left with:

    { 
 {0.2, 25, -11},
 {0.3, 24, 0},
 {0.4, 21, 9},
 {0.5, 16,16},
 {0.6, 9, 21},
 {0.7, 0, 24},
 {0.8, -11, 25}}

I guess both transformations are identical so if I know how to do one, I can do the other. I just mentioned both simply because it might be feasible to do both in one shot and that code might teach me more than learning the code for a single transformation.

Also, I have a hundred different lists and I'd like to be able to do this transformation to all 100 of them in one shot, using Table or something.

Thanks, PS: I have read advanced help but I can't seem to figure out how to get the shaded grey background on certain text so I have instead put $$ to get things like $ list[1][[*, 2]] $ as latex math above in my question to appear distinguished from the rest of the text.

Answer 1

There might be a more efficient way, but here is a first shot, that keeps the order of the list

valueMax = First@list[1][[First@Flatten@Position[list[1][[All, 3]],Max@list[1][[All, 3]]]]]

0.8

valueMin = First@list[1][[First@Flatten@Position[list[1][[All, 2]],Max@list[1][[All, 2]]]]]

0.2

Complement[list[1],Select[list[1], #[[1]] > valueMax || #[[1]] < valueMin &]]

{{0.2, 25, -11}, {0.3, 24, 0}, {0.4, 21, 9}, {0.5, 16, 16}, {0.6, 9, 21}, {0.7, 0, 24}, {0.8, -11, 25}}

The improved version

(My value selection, wxffles' "DeleteCases")

t3[a_] :=  With[{valueMax = First@a[[First@Flatten@Position[a[[All, 3]], Max@a[[All, 3]]]]], 
                 valueMin = First@a[[First@Flatten@Position[a[[All, 2]], Max@a[[All, 2]]]]]}, 
                DeleteCases[ a, {first_, _, _} /; first > valueMax || first < valueMin]]

We can compare the timing of this one (t3), the old version(t2), belisarius'(t4) and wxffles (t3)

 t1[a_] := With[{max2 = Ordering[a, 1, #1[[2]] > #2[[2]] &][[1]], 
                 max3 = Ordering[a, 1, #1[[3]] > #2[[3]] &][[1]]}, 
                DeleteCases[a, {first_, _, _} /; first > a[[max3, 1]] || first < a[[max2,1]]]]

 t2[a_] := With[{valueMax = First@a[[First@Flatten@Position[a[[All, 3]], Max@a[[All, 3]]]]], 
                 valueMin = First@a[[First@Flatten@Position[a[[All, 2]],Max@a[[All, 2]]]]]},
                Complement[a, Select[a, #[[1]] > valueMax || #[[1]] < valueMin &]]]

 maxC[l_List, col_Integer] := l[[First[Ordering[-l[[All, col]]]]]]
 sel[l_List, colsel_, colcomp_, op_] := Select[l, op[#[[colcomp]], maxC[l, colsel][[colcomp]]] &];
 t4[l_List] := sel[sel[l, 3, 1, LessEqual], 2, 1, GreaterEqual]

And make a little plot:

 ListPlot[Transpose@
   Table[list[1] = Table[{N[i/10], 25 - (i - 2)^2, 25 - (i - 8)^2}, {i, 1, n}];
         {First@AbsoluteTiming@t1[list[1]],
          First@AbsoluteTiming@t2[list[1]],
          First@AbsoluteTiming@t3[list[1]],
          First@AbsoluteTiming@t4[list[1]]}, {n, 1, 100}], Joined -> True, ImageSize -> 500]

It looks like the calculation of the limiting values of t2 and t3 are the fastest. And using DeleteCases is a faster than Complement. So for long lists method t3 is the fastest.

Answer 2

To find where the maximum is you can use Ordering:

which = Ordering[list, 1, #1[[3]] > #2[[3]] &][[1]]

where we have sorted by the 3rd column and just taken the first element.

Then to delete the cases we don't want, we use DeleteCases

DeleteCases[list, {first_, _, _} /; first > list[[which, 1]]]

We can put your transformation all together in a function:

ClearAll[t];
t[a_] :=
  With[{max2 = Ordering[a, 1, #1[[2]] > #2[[2]] &][[1]], 
        max3 = Ordering[a, 1, #1[[3]] > #2[[3]] &][[1]]},
  DeleteCases[a, {first_, _, _} /; first > a[[max3, 1]] || first < a[[max2, 1]]]]

Then apply as so:

t[list[1]]

Answer 3

list[1] = Table[{N[i/10], 25 - (i - 2)^2, 25 - (i - 8)^2}, {i, 1, 10}];
maxC[l_List, col_Integer] := l[[First[Ordering[-l[[All, col]]]]]]
sel[l_List,colsel_,colcomp_, op_]:=Select[l, op[#[[colcomp]], maxC[l, colsel][[colcomp]]] &];
selF[l_List] := sel[sel[l, 3, 1, LessEqual], 2, 1, GreaterEqual];
selF@list[1]

And of course you can do

selF /@ Table[list[i],{i,n}]