How to find the boundary of a region from a dataset

The following function extractregion might be something to start with. First, it smoothes along the third entries in the data set by TotalVariationFilter. TTotalVariationFilter has the advantage over, e.g. GaussianFilter, that it tends to preserve edge jumps, which is really desired here. Afterwards, we interpolate the smoothed data set, plot a ContourPlot, extract the contour lines, and convert them to a single MeshRegion.

extractregion[data_, level_, smoothing_] := 
 Module[{a, n, g, contour},
  a = data;
  n = FirstPosition[Unitize[Subtract[a[[1 ;; -2, 1]], a[[2 ;; -1, 1]]]], 1][[1]];
  a[[All, 3]] = Flatten[TotalVariationFilter[Partition[a[[All, 3]], n], smoothing]];
  g = Interpolation[a];
  contour = 
   ContourPlot[
    g[x, y] == level, {x, Sequence @@ g[[1, 1]]}, {y, Sequence @@ g[[1, 2]]}];
  RegionUnion@Map[
    gc \[Function] MeshRegion[gc[[1]], Cases[gc, _Line, All]],
    Cases[contour, _GraphicsComplex, All]
    ]
  ]

This is how it behaves on the provide example data:

Show[
 ListDensityPlot[data, InterpolationOrder -> 0, PlotRange -> All, 
  AspectRatio -> 4/5],
 extractregion[data, 0.5, 3],
 extractregion[data, -0.5, 1.2]
 ]

enter image description here

It doesn't close the quarter of the disk in the lower left corner. I don't now an elegant way to do that at the moment.


You can (1) use ListDensityPlot with options InterpolationOrder -> 1 and MeshFunctions to create mesh lines, and (2) use the function smoothCP from this answer to smooth the mesh lines:

ClearAll[smoothCP]
smoothCP = Module[{pr = PlotRange @ #,  nF =  Nearest[Join @@ Cases[Normal @ #, 
       Line[a_] :> Transpose[#2 /@ Transpose@a], ∞]]},
   # /. GraphicsComplex[a_, b__] :> GraphicsComplex[ 
       If[Or @@ MemberQ @@@ Thread @ {pr, #}, #, First @ nF @ #] & /@ a, b] ] &;
   
ldp1 = ListDensityPlot[data, InterpolationOrder -> 0, 
   PlotRange -> All, AspectRatio -> 4/5, ImageSize -> 300];
ldp2 = ListDensityPlot[data, InterpolationOrder -> 1, 
   PlotRange -> All, AspectRatio -> 4/5, ImageSize -> 300, PlotStyle -> None,
   MeshFunctions -> {Round@#3 &}, Mesh -> 2, MeshStyle -> Directive[Thick, Red]];

 Row[{Show[ldp1, ldp2], Show[ldp1, smoothCP[ldp2, GaussianFilter[#, {5, 5}] &], 
   PlotRange -> All]}]

enter image description here

Is it possible to extract the contours as separate lists?

To extract the smoothed lines, you can use

lines = Cases[Normal[smoothCP[ldp2, GaussianFilter[#, {5, 5}] &]], _Line, Infinity]
Short /@ lines

{Line[{{0., 0.387454}, << 58 >>, {0.392532, 0.}}],
Line[{{0.504121, 0.483339}, << 146 >>, {0.504121, 0.483339}}]}

To get just the coordinates of the two lines, use Line[x_, ___]:>x instead of _Line above.