2
$\begingroup$

Following my previous question Move axis and tick labels in RegionPlot to the top, change border color now, I have the following function

g := -(8 (1 + t) Sin[Sqrt[t] y] - (3 + t)^2 Sin[
        Sqrt[t] (2  π + y)])^2 + 
   270.86 (1 + t)^2 Cos[(2  π Sqrt[t])/3]^2 Sin[ π Sqrt[t]]^2;

RegionPlot[g >= 0, {y, 0, 2}, {t, 1, 3.8}, PlotPoints -> 200, 
 FrameLabel -> {"t", "y"}]

which the result is plot 1. I need to have a plot like the second plot. Since here the two portions are connected, the methods in Move axis and tick labels in RegionPlot to the top, change border color do not help me. Is it possible to ask Mathematica to give me a plot like 2 in this case? Or, is there a way to do it manually using drawing tools in Mathematica?

P.S. I need to have such a plot over a large domain, therefore, plotting over different range separately and then merging them do not help.

enter image description here

$\endgroup$
4
$\begingroup$

(1) Replace boundary lines with White lines that are 1 pixel thick, (2) Rasterize, (3) ColorNegate, and (4) ImageMesh. These 4 steps give a mesh objects with polygons separated but polygon coordinates are scaled up. We use CoordinateBounds on the original RegionPlot coordinates and on the mesh coordinates and rescale mesh primitives back to original coordinates using RescalingTransform.

ClearAll[separatePolygons]
separatePolygons = Module[{imgmesh = ImageMesh @ ColorNegate @ 
     Rasterize[Graphics[#[[1]] /. l_Line :> {AbsoluteThickness[1], White, l}], 
       ImageResolution -> 200], 
     cb = CoordinateBounds @ #[[1, 1, 1]], cbm}, 
   cbm = CoordinateBounds @ MeshCoordinates @ imgmesh; 
   MeshPrimitives[imgmesh, 2] /. p_Polygon :> RescalingTransform[cbm, cb] /@ p] &;

Examples:

rp = RegionPlot[g >= 0, {y, 0, 2}, {t, 1, 3.8}, PlotPoints -> 200];

Row[{Show[rp, FrameLabel -> {"t", "y"}, ImageSize -> 400], 
    Graphics[MapIndexed[{EdgeForm[{Thick, ColorData[97]@#2[[1]]}], 
        Opacity[.5], ColorData[97]@#2[[1]], #} &, separatePolygons @ rp], 
      FrameLabel -> {"t", "y"}, ImageSize -> 400, AspectRatio -> 1, Frame -> True]}, 
  Spacer[20]] 

enter image description here

rp2 = RegionPlot[Cos[x] + Cos[y] <= 0, {x, 0, 4 Pi}, {y, 0, 4 Pi}, 
  PlotPoints -> 100]; 

Row[{Show[rp2, ImageSize -> 400], 
  Graphics[MapThread[{EdgeForm[{Thick, #2}], Opacity[.5], #2, #} &, 
    {#, ColorData["Rainbow"] /@ Rescale[Range[Length @ #]]} &@
     separatePolygons @ rp2], 
  ImageSize -> 400, AspectRatio -> 1, Frame -> True]}, Spacer[20]]

enter image description here

Replace Cos[x] + Cos[y] <= 0 with Cos[x] + Cos[y] >= 0 to get

enter image description here

Note: In versions prior to version 12, replace cb = CoordinateBounds @ #[[1, 1, 1]] with cb = CoordinateBounds @ #[[1, 1]].

$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.