4
$\begingroup$

I have an equation that I want to plot as a region plot but it takes a long time to plot and in the future, I will need to replot it multiple times so is it possible to replot a region plot from a table of data?

An example of a simpler equation and code to extract the data points is

plot = RegionPlot[x^2 + y^3 < 2, {x, -2, 2}, {y, -2, 2}]

dataPts = DeleteDuplicates@Flatten[Cases[Normal[plot], Polygon[x_] :> x, Infinity], 1];

This gives a {601,2} table of coordinates

Coordinates of region plot

which make up the region plot below.

RegionPlot

Can I recreate the region plot from a table of data?

$\endgroup$
3
  • 1
    $\begingroup$ This is not really an answer to your question, but a suggestion to what you want to achieve: Why don't you plot the region once, and then use Show to combine it with (I presume) other plots? reg = RegionPlot[...]; Show[reg, Plot[...]]; Show[reg, Plot[...]]; $\endgroup$
    – Domen
    Oct 31, 2021 at 16:08
  • 1
    $\begingroup$ As for the real question: take a look at NonConvexHullMesh. $\endgroup$
    – Domen
    Oct 31, 2021 at 16:19
  • $\begingroup$ @Domen The problem is that I might have to update the plot style retrospectively and then combine with other region plots using Show as you have suggested. As for using NonConvexHullMesh I don't see how this can be used to recreate a region plot when given a table of data but maybe I've misunderstood something. $\endgroup$
    – James
    Oct 31, 2021 at 16:51

2 Answers 2

2
$\begingroup$

As Domen mentioned, first fetch the "NonConvexHullMesh" function:

nchm= ResourceFunction["NonConvexHullMesh"]

Then create your data points:

plot = RegionPlot[x^2 + y^3 < 2, {x, -2, 2}, {y, -2, 2}]
dataPts = DeleteDuplicates@Flatten[Cases[Normal[plot], Polygon[x_] :> x, Infinity], 1];

Now apply the function to the data points:

newregion = nchm[dataPts, 0.7];

Finally compare the original region and the new region:

Region[newregion, Frame -> True, PlotRange -> {-2, 2}, PlotLabel -> "New Region"]
plot

enter image description here

$\endgroup$
2
  • $\begingroup$ Thanks! For the sensitivity option for NonConvexHullMesh is there a sure-fire setting choice of value for getting as close to the original region plot as possible or do you try various values and select the value which gives the best agreement? $\endgroup$
    – James
    Oct 31, 2021 at 19:23
  • $\begingroup$ The larger the sensitivity value, the more the region will become convex. You have to try for an optimal value. $\endgroup$ Oct 31, 2021 at 19:42
2
$\begingroup$

An alternative approach is to extract the coordinates of Line primitives (instead of Polygon coordinates):

plot = RegionPlot[x^2 + y^3 < 2, {x, -2, 2}, {y, -2, 2}, ImageSize -> 400];

boundaryCoords = Cases[Normal @ plot, Line[x_] :> x, All];

lines = Line /@ boundaryCoords;

graphicsBoundary = Graphics[{AbsoluteThickness[1.6], ColorData[97]@1, lines}, 
  Options[plot]];

If the region does not have any holes, we can simply wrap boundaryCoords with Polygon to reproduce the union of polygons in original RegionPlot output:

polygons = Polygon /@ boundaryCoords;

graphicsRegion = Graphics[{EdgeForm[{AbsoluteThickness[1.6], ColorData[97]@1}], 
    FaceForm[Opacity[.3]], ColorData[97]@1, polygons}, Options[plot]];

Row[{Show[plot, PlotLabel -> Style["plot", 24]], 
  Show[graphicsBoundary, PlotLabel -> Style["graphicsBoundary", 24]], 
  Show[graphicsRegion, PlotLabel -> Style["graphicsRegion", 24]]}]

enter image description here

If the region has holes as in

plot = RegionPlot[ x^2 + y^3 < 2 && (1/4 <= (x + 1)^2 + (y + 1)^2 && 
      1/4 <= (x - 1)^2 + (y + 1)^2) || 
   0 <= (x + 1)^2 + (y + 1)^2 <= 1/16 || 0 <= (x - 1)^2 + (y + 1)^2 <= 1/16,
   {x, -2, 2}, {y, -2, 2},  ImageSize -> 400]

this approach gives:

enter image description here

So we need additional processing of lines to get the desired primitives. One possible approach is to group lines by region inclusion (using RegionWithin + RelationGraph + WeaklyConnectedComponents) and construct FilledCurves for each group of lines:

filledcurves = ReplaceAll[l : {__Line} :> FilledCurve[List /@ l]] @
    WeaklyConnectedComponents @
       RelationGraph[RegionWithin[Polygon @@ #, Polygon @@ #2] &, lines];

graphicsRegion = Graphics[{EdgeForm[{AbsoluteThickness[1.6], ColorData[97]@1}], 
    FaceForm[Opacity[.3]], ColorData[97]@1, filledcurves}, 
   Options[plot]];

Row[{Show[plot, PlotLabel -> Style["plot", 24]], 
  Show[graphicsBoundary, PlotLabel -> Style["graphicsBoundary", 24]], 
  Show[graphicsRegion, PlotLabel -> Style["graphicsRegion", 24]]}, 
 Spacer[20]]

enter image description here

A more complicated example:

SeedRandom[1]
plot = RegionPlot[Evaluate[1 <= Sum[Sin[RandomReal[6, 2].{x, y}], {5}] <= 3], 
   {x, 0, 5}, {y, 0, 5}, PlotPoints -> 60, ImageSize -> 400];

boundaryCoords = Cases[Normal@plot, Line[x_] :> x, All];

lines = Line /@ boundaryCoords;

graphicsBoundary = Graphics[{AbsoluteThickness[1.6], ColorData[97]@1, lines}, 
   Options[plot]];

filledcurves = ReplaceAll[l : {__Line} :> FilledCurve[List /@ l]] @
   WeaklyConnectedComponents @
       RelationGraph[RegionWithin[Polygon @@ #, Polygon @@ #2] &, lines];


graphicsRegion = Graphics[{EdgeForm[{AbsoluteThickness[1.6], ColorData[97]@1}], 
    FaceForm[Opacity[.3]], ColorData[97]@1, filledcurves}, 
   Options[plot]];

Row[{Show[plot, PlotLabel -> Style["plot", 24]], 
  Show[graphicsBoundary, PlotLabel -> Style["graphicsBoundary", 24]], 
  Show[graphicsRegion, PlotLabel -> Style["graphicsRegion", 24]]}, 
 Spacer[20]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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