Change color of a plot without processing it all the time

Question

I have to do a RegionPlot of this strange function

func =  (x y)^2/z^2 Abs[1 - 1/(x)^2] < 1/(210)^2;

I do it with

plotFunc = RegionPlot[func  /. z -> 10, {x, -1, 1}, {y, -1, 1}, BoundaryStyle -> None,
                      PerformanceGoal -> "Quality", PlotPoints -> 250]

where I needed the PerformanceGoal and PlotPoints to improve the quality of my plot.

Now, I have to overlap plots of this kind for different values of $z$ but I am not sure of the set of color to use, I would like to just change the color at the end, when I'll do the Overlap[...] or Show[...]

Mathematica takes 13 secs to do the plot.

Is there a way to let Mathematica process the points of the plot once for all and then change quickly the color without wasting 13 secs of my time every time I want just to change the color?

I hope my question is clear.

Answer 1

Let me know if this fits your needs:

ClearAll[func, zSpec, plots];
func[x_, y_, z_] := (x y)^2/z^2 Abs[1 - 1/(x)^2] < 1/(210)^2;

zSpec = Range[0, 100, 10];
(color[#] = Blend["TemperatureMap", #/100]) & /@ zSpec;


 (* change plotting setting however you want, I don't have time to try with 250 plot points. 
    Just don't touch PlotStyle
 *)

plots = Table[
   (RegionPlot[func[x, y, #], {x, -1, 1}, {y, -1, 1}, 
        BoundaryStyle -> None, PerformanceGoal -> "Quality", 
        PlotPoints -> 250, PlotStyle -> Blue] /. 
       Directive[a___, Blue, b___] :> 
        Dynamic[Directive[a, color[#], b]]) &[z]
   , {z, zSpec}];

Panel@Grid[{
   {Row @ plots, SpanFromLeft}
   ,
   {
    Show[Reverse@plots, ImageSize -> 500],
    Panel@
     Grid[{"z = ", #, " : ", ColorSlider[Dynamic[color[#]]]} & /@ 
       zSpec],
    Button[
     "Reset", (color[#] = Blend["TemperatureMap", #/100]) & /@ zSpec, 
     ImageSize -> CurrentValue["DefaultButtonSize"]]
    }}, Alignment -> {Left, Top}
  ]

Answer 2

The quick-and-dirty method is to perform a preliminary discretization of your region, and then extract the needed points and polygons for subsequent styling:

With[{z = 10}, 
     reg = BoundaryDiscretizeRegion[
         ImplicitRegion[(x y)^2/z^2 Abs[1 - 1/x^2] < 1/210^2, {{x, -1, 1}, {y, -1, 1}}], 
         MaxCellMeasure -> {1 -> 0.01}, Method -> "Semialgebraic"]];

pts = MeshCoordinates[reg]; polys = MeshCells[reg, 2];

Graphics[{Red, GraphicsComplex[pts, polys]}]

Answer 3

Reducing the number of point increases the speed of calculation. I have tried with this guessing what you want:

pl = {};
maxz = 15;
Do[
   func = (x y)^2/z^2 Abs[1 - 1/(x)^2] < 1/(210.)^2;
   colf[z_] := Blend[{Yellow, Red}, N@(z/maxz)];
   plotFunc = RegionPlot[Evaluate@(func), {x, -1, 1}, {y, -1, 1}, 
   PlotPoints -> 100, BoundaryStyle -> None, PlotStyle -> colf[z]];
   pl = AppendTo[pl, plotFunc],
   {z, 1, maxz}
  ]
Blend[pl]