How does one adjust ColorFunction quality independently of surface quality?
There is indeed an alternative which you might should consider. You almost got it yourself by the given analysis of the situation in your question. While Plot3D
does only care of a good resolution of the function you plot and not the function you use for coloring, DensityPlot
uses your color function from the beginning and tries to resolve this as best as possible.
Therefore, one possible way is to use the DensityPlot
image as texture on your surface.
f[z_] := BesselI[0, 2 Sqrt[z]]/(1 - z)
img =
Rasterize[
DensityPlot[Arg[f[a + I b]], {a, -5, 5}, {b, -5, 5},
PlotPoints -> 30,
ColorFunction -> (ColorData[{"DarkRainbow", {-Pi, Pi}}][#] &),
ColorFunctionScaling -> False, Frame -> False,
PlotRangePadding -> 0, ImageMargins -> 0], "Image",
RasterSize -> 512];
Plot3D[Abs[f[a + I b]], {a, -5, 5}, {b, -5, 5},
PlotStyle -> Texture[img], Mesh -> None, Lighting -> "Neutral"]
Similar to halirutans answer you can let DensityPlot
determine the "good points", and then ListPlot3D
those:
ptsdp = Reap[
DensityPlot[Arg[f[a + I b]], {a, -5, 5}, {b, -5, 5},
PlotPoints -> 25, ColorFunction -> "DarkRainbow",
EvaluationMonitor :> Sow[{a, b}]]][[-1, 1]];
ListPlot3D[({#[[1]], #[[2]], Abs@f[Complex @@ #]}) & /@ ptsdp,
ColorFunction -> (ColorData[{"DarkRainbow", {-\[Pi], \[Pi]}}][Arg[f[#1 + I #2]]] &),
ColorFunctionScaling -> False]
This generally has the drawback that the 3D sample points wont get refined further when need be. One possibility would be to Join
the points with the ones Plot3D
picks.
I was going to use this trick but couldn't figure out the syntax for Plot3D
You can add Arg[f] explicitly in the function to plot with ridiculously small coefficient. Then Mathematica will render points as you wish. Also it is good idea to put ExclusionStyle->Automatic to get rid of white lines. Below is your code with these corrections:
Block[{f = BesselI[0, 2 Sqrt[#]]/(1 - #) &},
Plot3D[Abs[f[a + I b]] + 10^-50 Arg[f[a + I b]] // Evaluate, {a, -5,
5}, {b, -5, 5}, PlotPoints -> 35,
ColorFunction -> (ColorData[{"DarkRainbow", {-\[Pi], \[Pi]}}][
Arg[f[#1 + I #2]]] &), ColorFunctionScaling -> False,
Mesh -> None,
ExclusionsStyle -> Automatic]
]
I also added Evaluate command, then result is plotted slightly faster. No need to increase WorkingPrecision or set up Performance goal. The output is:
There is a little flaw behind the peak, at the cross of blue and red regions. It is cured by increasing the number of PlotPoints, the cost is time of plotting.