Smooth out contour in RegionPlot/ContourPlot

Question

I would like to smooth out the jagged edges in the outermost contours in the following plot:

I have data of values as a function of variables (x,y) in the form

data = {{{x1,y1},z1},{{x2,y2},z2},...};

The figure is produced by

data = << "data.dat";
fnct = Interpolation[data];    
RegionPlot[{fnct[x, y] > 2, fnct[x, y] > 100, fnct[x, y] > 140}, {x, 10^-2, 10^1}, {y, 0, 3},MaxRecursion->5]

The outer edges seem jagged I guess because the data is not very good there. I need to fit a smooth contour instead. I've looked at some other questions like Smoothing ListContourPlot contours but that uses ListContourPlot which for me takes ages and produces a bad result even for the original figure.

Any help appreciated.

The data can be found here:

https://dl.dropboxusercontent.com/u/34796693/data.dat

Answer 1

First we import the data, which OP is kind enough to leave in his Dropbox for these past 18 months.

data = N@Get["https://dl.dropboxusercontent.com/u/34796693/data.dat"];

Next we look at the data and notice that it is on a rectangular grid,

Dimensions[data]
Dimensions@Gather[data[[All, 1, 1]]]
(* {180901, 2} *)
(* {601, 301} *)

This is going to make all the difference here (if it weren't on a rectangular grid than you wouldn't have been able to do a decent Interpolation anyway).

The plan here is to apply a MovingAverage along the rows and columns of the grid. MovingAverage likes to work on matrices or vectors, not lists like {{{x1,y1},z1},{{x2,y2},z2}....}, so there are a couple of reshaping steps thrown in here for good measure.

npts = 10;
smootheddata = {{#1, #2}, #3} & @@@
   Flatten[
    Transpose[
     MovingAverage[#, npts] & /@
      Transpose[
       MovingAverage[#, npts] & /@
        Partition[Flatten /@ data, 301]
       ]
     ]
    , 1];

Now you just do as you were doing before, create an interpolation function then apply RegionPlot to it, but now you must be aware that you have a smaller range of gridpoints after applying the averaging.

{{xmin, xmax}, {ymin, ymax}} = 
 MinMax /@ Transpose[smootheddata[[All, 1]]]
fnct = Interpolation[smootheddata];
RegionPlot[{fnct[x, y] > 2, fnct[x, y] > 100, fnct[x, y] > 140}, {x, 
  xmin, xmax}, {y, ymin, ymax}, MaxRecursion -> 5]

(* {{0.0107256, 9.66286}, {0.045, 2.955}} *)

You can see that it is probably fine to just average the rows, but the best results come from averaging both rows and columns.

Above I've used 10 as the number of elements to average over, but you can get a smoother plot by including more elements. This will have the effect of decreasing the size of the grid points so you have to choose the best option. Here are a few values for npts