How to export ContourPlot to vector graphics with fewer nodes?

Question

Export["C:\\Users\\me\\Desktop\\example.pdf", 
ContourPlot[(x^2 + y^2 - 1)^3 == x^2*y^3, {x, -5, 5}, {y, -5, 5}, 
PlotPoints -> 10, MaxRecursion -> 10, ContourStyle -> {Black}, 
Axes -> False, Frame -> False]]  

Then I import example.pdf to Inkscape, there are more than 20k nodes,actually it's not a complex plot, I think 100 nodes are enough. How to control the nodes number when ContourPlot?

Answer 1

ContourPlot is not very efficient at making smooth graphs in general. In the present case, you can solve the equation for an explicit formula in polar coordinates:

polar = (x^2 + y^2 - 1)^3 == x^2*y^3 /. {x -> r Cos[t], y -> r Sin[t]} // Simplify;
foo = r /. First@Solve[polar, r, Reals];
PolarPlot[foo, {t, -Pi/2, 3 Pi/2}]
Cases[Normal@%, Line[p_] :> Length@p, Infinity]

You can use the options to affect the number of points generated:

PlotPoints -> n,    (* default 50 *)
MaxRecursion -> r,  (* default 6 *)
Method -> {"Refinement" -> {"ControlValue" -> deg °}} (* default 5 *)

The defaults produce 743 points. Much less than the OP's contour plot. IMO, hoping to get a smooth plot with ~100 points is very optimistic.

You might be able to do better splitting the polar plot in half, since that will resolve the cusps without excessive refinement:

Show[PolarPlot[foo, {t, -Pi/2, Pi/2}], PolarPlot[foo, {t, Pi/2, 3 Pi/2}]]

Here's a demo for exploring the option settings:

Manipulate[
 With[{plot = Show[
     PolarPlot[foo, {t, -Pi/2, Pi/2},
      PlotPoints -> n, MaxRecursion -> r,
      Mesh -> mesh, MeshStyle -> Red, 
      Method -> {"Refinement" -> {"ControlValue" -> deg °}},
      (*Exclusions -> None,*)
      PerformanceGoal -> "Quality"],
     PolarPlot[foo, {t, Pi/2, 3 Pi/2},
      PlotPoints -> n, MaxRecursion -> r,
      Mesh -> mesh, MeshStyle -> Red, 
      Method -> {"Refinement" -> {"ControlValue" -> deg °}},
      (*Exclusions -> None,*)
      PerformanceGoal -> "Quality"]
     ]},
  Graphics[
   First@plot,
   Frame -> True,
   PlotRange -> Dynamic@pr[zoom],
   PlotLabel -> 
    Row[{Total@Cases[Normal@plot, Line[p_] :> Length@p, Infinity], 
      " points"}],
   AspectRatio -> 1
   ]
  ],
 {{deg, 5}, 1, 50, Appearance -> "Labeled"},
 {{n, 50}, 10, 200, 1, Appearance -> "Labeled"},
 {{r, 6}, 0, 15, 1, Appearance -> "Labeled"},
 {{zoom, 0}, -1, 1},
 {mesh, {None, All}},
 {{pr, Interpolation[{
     {-1, {{-0.1, 0.1}, {-1.1, -0.9}}},
     {0, {{-5, 5}, {-5, 5}}},
     {1, {{-0.1, 0.1}, {0.9, 1.1}}}
     }, InterpolationOrder -> 2]},
  None}
 ]

200 points (above) do fairly well, except perhaps at the cusps. See the mesh button to All to see all the points.

Answer 2

This problem can easily be solved with the Douglas-Peucker algorithm, which I have explained and implemented in an article.

The original line has 35,544 points:

cp = ContourPlot[
   (x^2 + y^2 - 1)^3 == x^2*y^3,
   {x, -5, 5},
   {y, -5, 5},
   PlotPoints -> 10,
   MaxRecursion -> 10,
   ContourStyle -> {Black},
   Axes -> False,
   Frame -> False
   ];
line = First@Cases[Normal@cp, Line[l_] :> l, Infinity];
Length@line

35544

It looks like this:

Graphics[Line[line]]

After applying the Douglas-Peucker algorithm with $\epsilon = 0.001$, the line has only 117 points:

dp[{a_, rest__, b_}, eps_] := Module[{df, maximum, pos},
  df = RegionDistance[Line[{a, b}]];
  {maximum} = MaximalBy[{rest}, df, 1];
  If[
   df[maximum] < eps,
   {a, b},
   {pos} = FirstPosition[{rest}, maximum];
   Join[
    dp[Part[{rest}, ;; pos]~Prepend~a, eps],
    Rest@dp[Part[{rest}, pos ;;]~Append~b, eps]
    ]
   ]
  ]
dp[list_List, _] := list

Length@dp[line, 0.001]

117

And it looks like this:

Graphics[
 Line@dp[line, 0.001]
 ]

One great thing about the Douglas-Peucker algorithm is that we can decide just how faithfully we want to reproduce the original line. If we can accept a larger error, compared to the original line, then we can go down to even fewer points:

Row[{
  Graphics@Line@dp[line, 0.1],
  Graphics@Line@dp[line, 0.01]
  }]

These images have only 12 and 38 points, respectively.

Answer 3

An alternative approach: Construct a BSplineFunction from the lines produced by ContourPlot and use it with ParametricPlot:

cp = ContourPlot[(x^2 + y^2 - 1)^3 == x^2*y^3, {x, -3, 3}, {y, -3, 3},
   PlotPoints -> 10, MaxRecursion -> 10, ContourStyle -> Black,
   Axes -> False, Frame -> False];

bsF = BSplineFunction[cp[[1, 1, 1]]];

pp1 =  ParametricPlot[bsF[t], {t, 0, 1}, Axes -> False, Frame -> False, 
   PlotPoints -> 4, PlotStyle -> Black, PlotRange -> {-3, 3}];

pp2 =  ParametricPlot[bsF[t], {t, 0, 1}, Axes -> False, Frame -> False, 
   PlotPoints -> 5, MaxRecursion -> 5, PlotStyle -> Black, PlotRange -> {-3, 3}];

nnodes = Cases[Normal@#, Line[x_] :> Length[x], All][[1]] & /@ {cp,  pp1, pp2}

{40807, 186, 127}

plotpoints = {10, 4, 5};
maxrecursion = {10, "Automatic (6)", 5};

labels = Grid[Transpose[{{"plotpoints", "maxrecursion", "nnodes"}, #}], 
     Dividers -> All] & /@ Transpose[{plotpoints, maxrecursion, nnodes}];

Style[Grid[{labels, {cp, pp1, pp2}}], ImageSizeMultipliers -> {1, 1}]

Answer 4

Another possibility is to use the new in M10 region functionality. Here is an ImplicitRegion representing your curve:

reg = ImplicitRegion[(x^2+y^2-1)^3==x^2*y^3, {x, y}];

Use DiscretizeRegion to convert it into a MeshRegion:

mesh = DiscretizeRegion[reg, MeshCellStyle->{0 -> None, 1 -> Black}]

The number of nodes is:

MeshCellCount[mesh, 0]

66

If you want a higher quality image, you can decrease the MaxCellMeasure:

mesh = DiscretizeRegion[reg, MeshCellStyle->{0 -> None, 1 -> Black}, MaxCellMeasure->.001]

Node count:

MeshCellCount[mesh, 0]

160