3
$\begingroup$
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?

$\endgroup$
4
  • 1
    $\begingroup$ Try disabling recursion and cranking up the setting for PlotPoints: ContourPlot[(x^2 + y^2 - 1)^3 == x^2*y^3, {x, -2, 2}, {y, -2, 2}, ContourStyle -> Black, Axes -> False, Frame -> False, MaxRecursion -> 0, PlotPoints -> 245] $\endgroup$ Mar 4, 2018 at 14:56
  • $\begingroup$ @J.M.your method reduce the nodes but make this plot not smooth.And,the curve is very bold, I am not sure if any method to make the line thinner. $\endgroup$
    – kittygirl
    Mar 4, 2018 at 15:42
  • $\begingroup$ For thickness, look up ContourStyle, Thickness and AbsoluteThickness. $\endgroup$
    – Michael E2
    Mar 4, 2018 at 17:39
  • $\begingroup$ I noticed you haven't accepted any answers to any of your questions. Perhaps we neglected to welcome you with our standard greeting: 1) As you receive help, try to give it too, by answering questions in your area of expertise. 2) Take the tour! 3) When you see good questions and answers, vote them up by clicking the gray triangles. Also, please remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign! $\endgroup$
    – Michael E2
    Mar 4, 2018 at 20:38

4 Answers 4

4
$\begingroup$

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]

Mathematica graphics

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}
 ]

Mathematica graphics

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

$\endgroup$
3
$\begingroup$

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

Mathematica graphics

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

Mathematica graphics

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]
  }]

Mathematica graphics

These images have only 12 and 38 points, respectively.

$\endgroup$
2
$\begingroup$

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}]

enter image description here

$\endgroup$
2
$\begingroup$

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}]

enter image description here

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]

enter image description here

Node count:

MeshCellCount[mesh, 0]

160

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.