15
$\begingroup$

Context

It would be nice to have a function which smooths contours plots once they have been done. There are various solutions which involve smoothing the data before making the contours, but here I am after a solution which operates on the graphics itself.

Example

pl = ContourPlot[
  x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -1, 1}, {y, -1, 1}, 
  Contours -> 3, PlotPoints -> 3,
  ContourShading -> False]

Mathematica graphics

Question

I would like to smooth this contour as post processing.

Attempt

The following seems to work for line contours as above.

Normal[pl] /. 
 Line[a__] :> 
  Line[ Transpose@{GaussianFilter[First /@ a, {5, 5}], 
     GaussianFilter[Last /@ a, {5, 5}]}]

Mathematica graphics

But what about smoothing Shaded contours? I.e. how to I smooth also the polygons? How can it be made to work on, say,

  pl = ContourPlot[
  x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -1, 1}, {y, -1, 1}, 
  Contours -> 3, PlotPoints -> 3,
  ContourShading -> True]
$\endgroup$
15
$\begingroup$

Update: Collecting the steps in a function:

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] ] &;

Examples:

p1 = ContourPlot[x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -2., 2.}, {y, -2., 2.}, 
     PlotPoints -> 6, Contours -> 4, ContourStyle -> Thick, ImageSize -> 400]; 
Row[{p1, smoothCP[p1, GaussianFilter[#, {5, 5}] &]}]

enter image description here

Row[{p1, smoothCP[p1, GaussianFilter[#, 2.5]&]}] 

enter image description here

Row[{p1, smoothCP[p1, GaussianFilter[#, {25, 25}] &]}] 

enter image description here

Row[{p1, smoothCP[p1, Downsample[#, 4]&]}] 

enter image description here

p2 = ContourPlot[x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -2., 2.}, {y, -2., 2.}, 
   PlotPoints -> 6, Contours -> 4, ContourStyle -> Thick, 
   ContourShading -> False, ImageSize -> 400]; 
Row[{p2, smoothCP[p2, GaussianFilter[#, {5, 5}] & ]}] 

enter image description here

lcp = ListContourPlot[Table[Sin[j^2 + i] + 3 RandomReal[{-0.05, 0.05}],
   {i, -Pi, Pi, 0.1}, {j, -Pi, Pi, 0.1}], Contours -> 2, ImageSize -> 400, 
   ColorFunction -> "Rainbow"];
Row[{lcp, smoothCP[lcp, GaussianFilter[#, 10] &]}, Spacer[5]]

enter image description here

Original answer:

pl = ContourPlot[ x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -1, 1}, {y, -1, 1}, 
   Contours -> 3, PlotPoints -> 3, ContourStyle -> Thick, ImageSize -> 400];
pnts =  Join @@ Cases[Normal[pl],  Line[a_] :> 
   Transpose[GaussianFilter[#, {5, 5}]& /@ Transpose[a]], ∞]; 
nf = Nearest[pnts];

pl2 = pl /. GraphicsComplex[a_, b__] :>  
  GraphicsComplex[If[Or @@ (Abs[#] == 1. & /@ #), #, nf[#][[1]]] & /@ a, b];
Row[{pl, pl2}]

enter image description here

$\endgroup$
  • $\begingroup$ You example works great, but for my own plot the colored area does not always follow the new position of the line (I am using ListContourPlot). Probably just a strange Mathematica bug, but do you have any idea how to fix this. Can I extract the lines themselves and do a new contour plot with them? $\endgroup$ – Kvothe Sep 26 at 16:08
  • $\begingroup$ @Kvothe, can you post a small example of data with this issue? Or post a new question if the data is to large for the comment area? $\endgroup$ – kglr Sep 26 at 16:42
  • $\begingroup$ thanks for the quick response. Yes the data is too big. If I find a good minimal example I will ask it as a question. In this case removing a point far outside the region I was interested in somehow fixed the issue. (In fact I was looking for a minimal data set to post when I noticed that removing the outlier already fixed the issue.) $\endgroup$ – Kvothe Sep 26 at 17:31
8
$\begingroup$

Not perfect but a good start, the idea is to use your method to transform boundaries and then use this transformation rules for points used by original output:

pl = ContourPlot[
  x^2 + y^2 + RandomReal[{-0.1, 0.1}], {x, -1, 1}, {y, -1, 1}, 
  Contours -> 3, PlotPoints -> 3, ContourShading -> True, 
  ContourStyle -> Thick];

rules = Flatten@
  Cases[Normal[pl], 
   Line[a__] :> 
    Thread[a -> 
      Transpose@{GaussianFilter[First /@ a, {5, 5}], 
        GaussianFilter[Last /@ a, {5, 5}]}], \[Infinity]];

pl /. rules

enter image description here

$\endgroup$
  • $\begingroup$ I guess one problem will be that a given point will appear more than once in the set of rules having been smoothed differently. $\endgroup$ – chris Apr 30 '18 at 11:07
  • $\begingroup$ @chris yes, that sounds reasonable, will try to come up with something better. $\endgroup$ – Kuba Apr 30 '18 at 18:58
  • $\begingroup$ @chris they are not closed/regular by any means in general. $\endgroup$ – Kuba May 1 '18 at 18:49
8
$\begingroup$

Mean curvature flow and Laplacian smoothing can also be applied to the graph of a piecewise linear function for smoothing. Here a very brief and imperfect demonstration (using the function GraphDiffusionFlow from the cited post):

RandomSeed[20180506];
mesh2D = DiscretizeRegion[Rectangle[{-1, -1}, {1, 1}], 
   MaxCellMeasure -> {1 -> 0.05}];
vals = With[{pts2D = MeshCoordinates[mesh2D]},
   (pts2D^2).ConstantArray[1., 2] + 
    RandomVariate[NormalDistribution[0, 0.075], Length[pts2D]]
   ];
mesh3D = MeshRegion[Join[pts2D, Partition[vals, 1], 2], 
   MeshCells[mesh2D, 2, "Multicells" -> True]];
smoothedmesh3D = GraphDiffusionFlow[mesh3D, 20, 0.1, 0.8];
g = GraphicsRow[{mesh3D, smoothedmesh3D}, ImageSize -> Large]

enter image description here

This how the resulting height function looks as ContourPlot away from the boundary.

f = Interpolation[pts3D, InterpolationOrder -> 1];
fsmoothed = 
  Interpolation[MeshCoordinates[smoothedmesh3D], 
   InterpolationOrder -> 1];
r = .8;
g = GraphicsRow[{
   ContourPlot[f[u, v], {u, -r, r}, {v, -r, r}, Contours -> 20],
   ContourPlot[fsmoothed[u, v], {u, -r, r}, {v, -r, r}, Contours -> 20]
   }, ImageSize -> Large]

enter image description here

However, the current boundary conditions for the 3D-flow are not well-suited for this task:

r = 1.;
g = GraphicsRow[{
   ContourPlot[f[u, v], {u, -r, r}, {v, -r, r}, Contours -> 20],
   ContourPlot[fsmoothed[u, v], {u, -r, r}, {v, -r, r}, Contours -> 20]
   }, ImageSize -> Large]

enter image description here

There are certainly ways to fix that, though.

$\endgroup$

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.