Putting a Graphics3D primitive on a Plot3D

Question

Clear[x, y, expr]
expr = 5 x y - x^4 - y^4;
max = Maximize[expr, {x, y}]

{25/8, {x -> -(Sqrt[5]/2), y -> -(Sqrt[5]/2)}}

I would like to generate a Plot3D and put a Ball at the maximum point.

Show[
 Plot3D[expr
  , {x, -3, 3}, {y, -3, 3}
  , PlotStyle -> Directive[Opacity[0.3], LightRed]
  , BoxRatios -> {1, 1, 1}
  ]
 , Graphics3D[{Red, AbsolutePointSize[12]
   , Ball[{-(Sqrt[5]/2), -(Sqrt[5]/2), 25/8}, 0.5]
   }]
 ]

This results in a squished disk so I try to restrict z-PlotRange.

Show[
Plot3D[expr
  , {x, -3, 3}, {y, -3, 3}
  , PlotStyle -> Directive[Opacity[0.3], LightRed]
  , PlotRange -> {{-3, 3}, {-3, 3}, {-10, 10}}
  ]
 , Graphics3D[{Red, AbsolutePointSize[12]
   , Ball[{-(Sqrt[5]/2), -(Sqrt[5]/2), 25/8}, 0.5]
   }
  ]
 ]

---

The two plots are shown below.

---

I have seen a similar post 157532 but it is about stretching/scaling the entire graphic. I want to ignore the rest of the elongated plot3D and focus on the part around the maximum point.

Question

I can put a Point at the max location without any problems and it appears round. But how do I put a 3D primitive there such as a Ball? Thanks for your time and your replies in advance.

Answer 1

We can use the function scaleSphere from this answer to a closely related question to Scale Sphere and Ball objects so that they look like spheres and balls:

ClearAll[scaleSphere]
scaleSphere[br_, pr_] := Scale[#, Normalize[Abs[Subtract @@@ pr], Max]/br] &;

Examples:

p1 = Plot3D[expr, {x, -3, 3}, {y, -3, 3}, 
   PlotStyle -> Directive[Opacity[0.3], LightRed], 
   BoxRatios -> {1, 1, 1}];

Show[p1,
   Graphics3D[{Red, 
    scaleSphere[{1, 1, 1}, Charting`get3DPlotRange[p1]] @
      Ball[{-(Sqrt[5]/2), -(Sqrt[5]/2), 25/8}, 12]}], 
  PlotRange -> All]

p2 = Plot3D[expr, {x, -3, 3}, {y, -3, 3}, 
   PlotStyle -> Directive[Opacity[0.3], LightRed], 
   BoxRatios -> {1, 1/2, 2}, 
   PlotRange -> {{-3, 5}, {-5, 3}, {-300, 100}}];

Show[p2, 
  Graphics3D[{Red, 
    scaleSphere[{1, 1/2, 2}, Charting`get3DPlotRange[p2]] @
     Ball[{-(Sqrt[5]/2), -(Sqrt[5]/2), 25/8}, 12]}], 
  PlotRange -> All]