Cool example with ContourPlot+EvaluationMonitor

[psycho_dad]

The following example shows in real-time (sort of) how ContourPlot calculates a contour (in this example a unit circle):

f[x_, y_, freeze_] := (Pause[freeze]; (x^2 + y^2))
data = {}; freeze = 0.04;
Dynamic[ListPlot[data, Frame -> True, AspectRatio -> 1,
PlotStyle -> Blue, PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}},
Epilog -> Circle[{0, 0}]]]
ContourPlot[f[x, y, freeze] == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},
EvaluationMonitor :> AppendTo[data, {x, y}]];

Initially I just wanted to get all the points from ContourPlot, but then it dawned on me that using Dynamic I could do that in real time! I hope you like it :D

Cheers

PS Change the parameter freeze (set to 0.04 secs) to make the animation slower or faster.
PPS This is so cool, I just knew I had to share it!

[Murta]

Nice!.. I played with the code and made it shorter.
It's the same thing.

Dynamic[
ListPlot[data, Frame -> True, AspectRatio -> 1, PlotStyle -> Blue,
PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}}, Epilog -> Circle[{0, 0}]]]

data = {}; freeze = 0.01

ContourPlot[x^2 + y^2 == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},
EvaluationMonitor :> (AppendTo[data, {x, y}]; Pause[freeze])]

[]'s
Murta

[Ralph Dratman]

Could one of you please explain a little more? I think I get the
general idea about putting together the plot of an implicit function
by a sort of scanning process, but I don't understand the details.
Thank you.

Ralph

On Sun, Mar 18, 2012 at 3:43 AM, Murta <rodrig...@gmail.com> wrote:
> Nice!.. I played with the code and made it shorter.
> It's the same thing.
>

> Dynamic[
> ListPlot[data, Frame -> True, AspectRatio -> 1, PlotStyle -> Blue,
> PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}}, Epilog -> Circle[{0, 0}]]]

> data = {}; freeze = 0.01
>
> ContourPlot[x^2 + y^2 == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},
> EvaluationMonitor :> (AppendTo[data, {x, y}]; Pause[freeze])]
>
> []'s
> Murta
> On Mar 17, 4:51 am, psycho_dad <s.nesse...@gmail.com> wrote:

[David Kahle]

Yea, really nice work. Adding to Ralph's question - is there a particular method that Mathematica (predominantly) follows for this? Can you refer me to a good source? (Text, paper, etc?)

Cheers
david.

On Mar 19, 2012, at 5:01 AM, Ralph Dratman wrote:

> Could one of you please explain a little more? I think I get the
> general idea about putting together the plot of an implicit function
> by a sort of scanning process, but I don't understand the details.
> Thank you.
>
> Ralph
>
> On Sun, Mar 18, 2012 at 3:43 AM, Murta <rodrig...@gmail.com> wrote:
>> Nice!.. I played with the code and made it shorter.
>> It's the same thing.
>>

>> Dynamic[
>> ListPlot[data, Frame -> True, AspectRatio -> 1, PlotStyle -> Blue,
>> PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}}, Epilog -> Circle[{0, 0}]]]

>> data = {}; freeze = 0.01
>>
>> ContourPlot[x^2 + y^2 == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},
>> EvaluationMonitor :> (AppendTo[data, {x, y}]; Pause[freeze])]
>>
>> []'s
>> Murta
>> On Mar 17, 4:51 am, psycho_dad <s.nesse...@gmail.com> wrote:

[Kevin J. McCann]

Another variation on a very cool theme.

f[x_, y_, freeze_] := (Pause[freeze]; x^2 + y^2)
data = {}; freeze = 0.01;

Dynamic[
ListPlot[data, Frame -> True, AspectRatio -> 1, PlotStyle -> Blue,
PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}}, Epilog -> Circle[{0, 0}]]
]
ContourPlot[f[x, y, freeze] == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},

PlotPoints -> 30,
EvaluationMonitor :> {AppendTo[data, {x, y}],
If[Length[data] >= 600, data = Drop[data, 1]]}];

[psycho_dad]

Hi Ralph,
Well, the thing is that most Mathematica functions are sort of a "black box", ie you supply a set of functions and parameters and it produces a result. In this case you never see the intermediate steps/results, the source code is obviously not available and even if it was, according to the documentation in many cases it's not even human readable (for efficiency reasons).

Therefore, this example illustrates how one of the functions (ContourPlot) operates in real time: first it makes a grid in the 2D space specified by the user, eg {x, -1.5, 1.5} & {y, -1.5, 1.5}, and then it picks values of (x,y) close to the actual contour: my guess is it chooses the ones close to where Abs[x^2+y^2-1]<dr, where dr is a small number say 0.2 (of course this is just a guess). I'm posting some (quick and dirty) code below that illustrates this.

I hope this helps!

Cheers

PS Of course I have to mention that Mathematica also checks the corners of the region etc but that's another story ;)

--- Code ---

(* grab the data from ContourPlot *)
data = {};

ContourPlot[x^2 + y^2 == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},

EvaluationMonitor :> AppendTo[data, {x, y}]];

(* just take the grid *)
qq = data[[1 ;; 15*15]];

(* evaluate Abs[x^2+y^2-1] and take the ones <0.2, then plot *)
qq1 = Table[{Abs[qq[[i, 1]]^2 + qq[[i, 2]]^2 - 1], qq[[i, 1]],
qq[[i, 2]]}, {i, 1, Length[qq]}] // Sort;
qq1 = qq1[[1 ;; 32]][[All, {2, 3}]];
ListPlot[{qq, qq1}, PlotStyle -> {Blue, Red}, AspectRatio -> 1]

[psycho_dad]

Hi Kevin,

This was interesting indeed! Now, lets see which other Mathematica function we can reverse-engineer :D

Cheers,
psycho_dad

Disclaimer: This post is for educational and fun purposes only, I hope you (Wolfram research) don't misunderstand my "reverse-engineer" comment above :)

[djmpark]

I've been following this, trying to think of something to add or some
improvement without success but Kevin's example finally helped me think of
something useful.

The problem with the examples so far is that they are all centered on the
circle because it was easy to draw that with an Epilog option. With
Presentations I devised the following code that allows arbitrary contour
equations and easy adjustment of the parameters. Sometimes it's instructive
to show many points and then again with many fewer points to see where the
algorithm is concentrating its effort. Here are three examples:

<< Presentations`

DynamicModule[
{data = {},
freeze = 0.005,
eqn = 8 x y == 1,
prange = 1.6,
points = 15,
recursion = 4,
maxDataPoints = 500,
contourFunction},
contourFunction[monitor : (True | False)][expr_] :=
ContourDraw[expr, {x, -prange, prange}, {y, -prange, prange},
PlotPoints -> points, MaxRecursion -> recursion,
EvaluationMonitor :>
If[monitor, (AppendTo[data, {x, y}];
If[Length[data] >= maxDataPoints, data = Drop[data, 1]];
Pause[freeze]), None]];
Print@
Draw2D[
{contourFunction[False][eqn],
Blue,
Dynamic[ListDraw[data]]
},
Frame -> True,
PlotRange -> 1.6];
contourFunction[True][eqn];
]

DynamicModule[
{data = {}, freeze = 0.0005,
eqn = Sin[5 x + 6 y^2] Cos[5 y^2 + 10 x] == 0.2,
prange = 0.7,
points = 30,
recursion = 3,
maxDataPoints = 2000,
contourFunction},
contourFunction[monitor : (True | False)][expr_] :=
ContourDraw[expr, {x, -prange, prange}, {y, -prange, prange},
PlotPoints -> points, MaxRecursion -> recursion,
EvaluationMonitor :>
If[monitor, (AppendTo[data, {x, y}];
If[Length[data] >= maxDataPoints, data = Drop[data, 1]];
Pause[freeze]), None]];
Print@
Draw2D[
{contourFunction[False][eqn],
Blue,
Dynamic[ListDraw[data]]
},
Frame -> True,
PlotRange -> prange];
contourFunction[True][eqn];
]

DynamicModule[
{data = {}, freeze = 0.0005,
eqn = Sin[5 x + 6 y^2] Cos[5 x^2 + 10 y] == 0.2,
prange = 0.7,
points = 30,
recursion = 3,
maxDataPoints = 2000,
contourFunction},
contourFunction[monitor : (True | False)][expr_] :=
ContourDraw[expr, {x, -prange, prange}, {y, -prange, prange},
PlotPoints -> points, MaxRecursion -> recursion,
EvaluationMonitor :>
If[monitor, (AppendTo[data, {x, y}];
If[Length[data] >= maxDataPoints, data = Drop[data, 1]];
Pause[freeze]), None]];
Print@
Draw2D[
{contourFunction[False][eqn],
Blue,
Dynamic[ListDraw[data]]
},
Frame -> True,
PlotRange -> prange];
contourFunction[True][eqn];
]

Watching these plots, it appears that the algorithm follows a two phase
strategy. First it attempts to divide the domain into regions that isolate
the contour lines. The sample points are heavily concentrated in the regions
between the actual contours and are nowhere near the contours. It seems to
spend an inordinate amount of time on this. Then, only after the contours
have been isolated, does the algorithm move to generating points on or near
the contour lines. One wonders if there is a theorem that, given enough
recursion and a fine enough starting mesh and some conditions on the
function, the algorithm will always isolate and refine the contour lines.


David Park
djm...@comcast.net
http://home.comcast.net/~djmpark/index.html

From: Kevin J. McCann [mailto:k...@KevinMcCann.com]


Another variation on a very cool theme.

f[x_, y_, freeze_] := (Pause[freeze]; x^2 + y^2) data = {}; freeze = 0.01;

Dynamic[
ListPlot[data, Frame -> True, AspectRatio -> 1, PlotStyle -> Blue,
PlotRange -> {{-1.6, 1.6}, {-1.6, 1.6}}, Epilog -> Circle[{0, 0}]]
]
ContourPlot[f[x, y, freeze] == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},

PlotPoints -> 30,
EvaluationMonitor :> {AppendTo[data, {x, y}],
If[Length[data] >= 600, data = Drop[data, 1]]}];

On 3/17/2012 3:51 AM, psycho_dad wrote: