20
$\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]
Improve this question
$\endgroup$
1

3 Answers 3

Reset to default
18
$\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

Improve this answer
$\endgroup$
3
  • $\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$ Commented Sep 26, 2019 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$ Commented Sep 26, 2019 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$ Commented Sep 26, 2019 at 17:31
12
$\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.

Improve this answer
$\endgroup$
9
$\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

Improve this answer
$\endgroup$
3
  • $\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$ Commented Apr 30, 2018 at 11:07
  • $\begingroup$ @chris yes, that sounds reasonable, will try to come up with something better. $\endgroup$ Commented Apr 30, 2018 at 18:58
  • $\begingroup$ @chris they are not closed/regular by any means in general. $\endgroup$ Commented May 1, 2018 at 18:49

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.