Weird plot with SphericalPlot3D

SphericalPlot3D is having problems where the radius goes to infinity. You can use RegionFunction to restrict the plotting region to a range where the function is well-behaved:

SphericalPlot3D[
  Sqrt[1/(Sin[θ]^2 Cos[2 ϕ] - Cos[θ]^2)], {θ, 0, π}, {ϕ, 0, 2 π},
  MaxRecursion -> 4, PlotRange -> {-3, 3}, 
  RegionFunction -> Function[{x, y, z, θ, ϕ, r}, 0 < r < 5]
]

Mathematica graphics

There's still the question of where that extra garbage comes from and how to get rid of it more robustly, since it tends to reappear if we change the PlotRange, etc. First, note that it doesn't only appear in SphericalPlot3D. If we Plot3D the same function, we get:

 func[θ_, ϕ_] = Sqrt[1/(Sin[θ]^2 Cos[2 ϕ] - Cos[θ]^2)];
 Plot3D[func[θ, ϕ], {θ, 0, π}, {ϕ, 0, 2 π}, MaxRecursion -> 4, PlotRange -> {0, 3}]

Mathematica graphics

There are spurious zero values that appear where func should be imaginary and thus not plotted. If we try to restrict the plotting region to the range in which func is real using RegionFunction, it only gets worse:

denom[θ_, ϕ_] = (Sin[θ]^2 Cos[2 ϕ] - Cos[θ]^2);
Plot3D[func[θ, ϕ], {θ, 0, π}, {ϕ, 0, 2 π}, 
  MaxRecursion -> 4, PlotRange -> {0, 3}, 
  RegionFunction -> Function[{θ, ϕ, z}, denom[θ, ϕ] > 0]
]

Mathematica graphics

This seems like buggy behavior to me, since these spurious points are outside the region that we requested to be plotted. Increasing the WorkingPrecision doesn't seem to help.

Another approach to restricting the plotting region is to make the function evaluate to Null where it would be imaginary:

Plot3D[If[denom[θ, ϕ] > 0, func[θ, ϕ]], {θ, 0, π}, {ϕ, 0, 2 π}, 
  MaxRecursion -> 4, PlotRange -> {0, 3}
]

Mathematica graphics

Almost, but not quite. If we try both techniques together, though, it seems to work:

Plot3D[If[denom[θ, ϕ] > 0, func[θ, ϕ]], {θ, 0, π}, {ϕ, 0, 2 π},
  MaxRecursion -> 4, PlotRange -> {0, 3}, 
  RegionFunction -> Function[{θ, ϕ, z}, denom[θ, ϕ] > 0]
]

Mathematica graphics

Great, we might think, we've got a general solution -- let's try it with SphericalPlot3D:

SphericalPlot3D[If[denom[θ, ϕ] > 0, func[θ, ϕ]], 
  {θ, 0, π}, {ϕ, 0, 2 π}, 
  MaxRecursion -> 4, PlotRange -> {-3, 3}, 
  RegionFunction -> Function[{x, y, z, θ, ϕ, r}, denom[θ, ϕ] > 0]
]

Mathematica graphics

Well, back to the drawing board.

What does seem to work is to put some arbitrary large value in by hand wherever the function would be imaginary or infinite:

SphericalPlot3D[If[denom[θ, ϕ] > 0, func[θ, ϕ], 1000], 
  {θ, 0, π}, {ϕ, 0, 2 π}, 
  MaxRecursion -> 7, PlotRange -> {-10, 10}
]

Mathematica graphics

This seems to be a general fix for the SphericalPlot3D case, although we have to increase the MaxRecursion to get rid of ragged edges on the surface.


This seems to fix part of the problem:

SphericalPlot3D[{ -Sqrt[
    1/(Sin[θ]^2 Cos[2 ϕ] - Cos[θ]^2)], 
  Sqrt[1/(Sin[θ]^2 Cos[2 ϕ] - Cos[θ]^2)]},
 {θ, π/4, 3 π/4}, {ϕ, π/4, -π/4},
 MaxRecursion -> 4]

enter image description here