Select elements from nested list where one element is largest

Question

I'm trying to speed up the following, but implementing efficient pattern matching isn't intuitive to me yet, even with lots of examples.

I have a list of ((x1,y1,z1), (x2,y2,z2)) pairs, and I want to make a new list selecting the (x,y,z) from the pair where the z value is greatest. The following works, but is slow. What is an efficient way to do this?

points={
{{30.7058, -2326.85, 420000.}, {31.4061, -1391.63, 479968.}},
{{47.2775, -2326.72, 479960.}, {48.4709, -1391.63, 420090.}},
{{36.9202, -2326.81, 479968.}, {37.8054, -1391.65, 420000.}},
{{51.4203, -2326.67, 420090.}, {52.7372, -1391.6,  479908.}},
{{34.8488, -2326.83, 420090.}, {35.6723, -1391.65, 479968.}}
}
set1=Position[points[[;; , 1, 3]], s_ /; s >450000];
set2=Position[points[[;; , 2, 3]], s_ /; s >450000];
Join[Extract[points[[;;,1]],set1],Extract[points[[;;,2]],set2]]

{
{31.4061, -1391.63, 479968.},
{47.2775, -2326.72, 479960.},
{36.9202, -2326.81, 479968.},
{52.7372, -1391.6,  479908.},
{35.6723, -1391.65, 479968.}
}

In case it prompts an answer where I can get the right xyz values to start with, these pairs are the solutions of the intersection of a bunch of lines with a sphere, where all the lines intersect the sphere twice:

Solve[(x - x0)/mx == (y - y0)/my == (z - z0) / mz && (x - xs0)^2 + (y - ys0)^2 + (z - zs0)^2 == rs^2, {x, y, z}]

The solutions I need is sometimes the first or second one. If I include && z > 450000 in the Solve it also works, but solves much more slowly than without that, so I thought I should extract them after the Solve.

Answer 1

You said you were interested in an efficient solution. I think the following should be pretty efficient:

maxZ[pts_] := Total[
    pts Transpose[{#, 1-#}& @ UnitStep[pts . {0, 0, 1} . {1, -1}]],
    {2}
]

For your example:

maxZ[points]

{{31.4061, -1391.63, 479968.}, {47.2775, -2326.72, 479960.}, {36.9202, -2326.81, 479968.}, {52.7372, -1391.6, 479908.}, {35.6723, -1391.65, 479968.}}

For a larger dataset:

SeedRandom[1];
pts = RandomReal[1, {10^6, 2, 3}];
r1 = maxZ[pts]; //AbsoluteTiming

r1[[;;10]]

{0.266662, Null}

{{0.817389, 0.11142, 0.789526}, {0.700474, 0.211826, 0.748657}, {0.422851, 0.247495, 0.977172}, {0.128821, 0.306427, 0.712012}, {0.390582, 0.819967, 0.325351}, {0.316876, 0.789804, 0.011978}, {0.391276, 0.458902, 0.458845}, {0.481571, 0.738297, 0.203011}, {0.544772, 0.562659, 0.767697}, {0.46418, 0.278197, 0.548402}}

Compare to J42161217's answer:

r2 = Last @ SortBy[#, Last]& /@ pts; //AbsoluteTiming
r2[[;;10]]

{3.26462, Null}

{{0.817389, 0.11142, 0.789526}, {0.700474, 0.211826, 0.748657}, {0.422851, 0.247495, 0.977172}, {0.128821, 0.306427, 0.712012}, {0.390582, 0.819967, 0.325351}, {0.316876, 0.789804, 0.011978}, {0.391276, 0.458902, 0.458845}, {0.481571, 0.738297, 0.203011}, {0.544772, 0.562659, 0.767697}, {0.46418, 0.278197, 0.548402}}

So, about an order of magnitude faster.

Answer 2

you can use

Last@SortBy[#,Last]&/@points   

{{31.4061, -1391.63, 479968.},
{47.2775, -2326.72, 479960.},
{36.9202, -2326.81, 479968.},
{52.7372, -1391.6, 479908.},
{35.6723, -1391.65, 479968.}}

Answer 3

One way is to Select the ones you want. You can Select by the maximum of each triplet

Select[Flatten[points, 1], Max[#] > 450000 &]

{{31.4061, -1391.63, 479968.}, {47.2775, -2326.72, 479960.}, 
 {36.9202, -2326.81, 479968.}, {52.7372, -1391.6, 479908.}, 
 {35.6723, -1391.65, 479968.}}

or by the third element explicitly:

Select[Flatten[points, 1], #[[3]] > 450000 &]