MathGroup Archive 2011

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Joining points of ListPlot

  • To: mathgroup at smc.vnet.net
  • Subject: [mg117356] Re: Joining points of ListPlot
  • From: DrMajorBob <btreat1 at austin.rr.com>
  • Date: Wed, 16 Mar 2011 06:26:09 -0500 (EST)

I also like this:

curves = Riffle[Table[{x, Sin[x]}, {x, 0., 2*Pi, .1}],
    Table[{x, Cos[x]}, {x, .05, 2*Pi, .1}]];
mean = Mean@Abs@Differences@Sort@curves[[All, 1]]
ListPlot[curves]

0.05

Clear[f]
f[{a_, b_}, {c_, d_}] :=
  Boole[mean/2 < Abs[a - c] < 2 mean] + Norm[{a, b} - {c, d}]
clusters =
   FindClusters[curves, 2, DistanceFunction -> f,
    Method -> "Agglomerate"];
Show[ListPlot@curves, Graphics@Line@clusters]

Bobby


On Tue, 15 Mar 2011 10:51:08 -0500, DrMajorBob <btreat1 at austin.rr.com>  
wrote:

> If I change "mesh" to "mean", the bug goes away:
>
> Clear[f]
> f[{a_, b_}, {c_, d_}] := Boole[Abs[a - c] < .1] + Norm[{a, b} - {c, d}]
> clusters =
>    FindClusters[curves, 2, DistanceFunction -> f,
>     Method -> "Agglomerate"];
> Show[ListPlot@curves, Table[Graphics@Line@c, {c, clusters}]]
>
> 2 mean == .1
>
> True
>
> curves = Riffle[Table[{x, Sin[x]}, {x, 0., 2*Pi, .1}],
>     Table[{x, Cos[x]}, {x, .05, 2*Pi, .1}]];
> mean = Mean@Abs@Differences@curves[[All, 1]]
> ListPlot[curves]
>
> 0.05
>
> Clear[f]
> f[{a_, b_}, {c_, d_}] :=
>   Boole[Abs[a - c] < 2 mean] + Norm[{a, b} - {c, d}]
> clusters =
>    FindClusters[curves, 2, DistanceFunction -> f,
>     Method -> "Agglomerate"];
> Show[ListPlot@curves, Table[Graphics@Line@c, {c, clusters}]]
>
> Bobby
>
> On Tue, 15 Mar 2011 10:45:14 -0500, DrMajorBob <btreat1 at austin.rr.com>  
> wrote:
>
>> This seems to do it perfectly in this case:
>>
>> curves = Riffle[Table[{x, Sin[x]}, {x, 0., 2*Pi, .1}],
>>     Table[{x, Cos[x]}, {x, .05, 2*Pi, .1}]];
>> mesh = Max@Abs@Differences@curves[[All, 1]]
>> ListPlot[curves]
>>
>> 0.05
>>
>> Clear[f]
>> f[{a_, b_}, {c_, d_}] := Boole[Abs[a - c] < .1] + Norm[{a, b} - {c, d}]
>> clusters =
>>    FindClusters[curves, 2, DistanceFunction -> f,
>>     Method -> "Agglomerate"];
>> Show[ListPlot@curves, Table[Graphics@Line@c, {c, clusters}]]
>>
>> But here's a BUG:
>>
>> 2 mesh == .1
>>
>> True
>>
>> Clear[f]
>> f[{a_, b_}, {c_, d_}] :=
>>   Boole[Abs[a - c] < 2 mesh] + Norm[{a, b} - {c, d}]
>> clusters =
>>    FindClusters[curves, 2, DistanceFunction -> f,
>>     Method -> "Agglomerate"];
>> Show[ListPlot@curves, Table[Graphics@Line@c, {c, clusters}]]
>>
>> (with VERY different clusters).
>>
>> Bobby
>>
>> On Tue, 15 Mar 2011 06:06:08 -0500, Daniel Lichtblau <danl at wolfram.com>  
>> wrote:
>>
>>> Antonio Mezzacapo wrote:
>>>> Thank you for answering.
>>>>
>>>> I don't have any functional form of this points. I have only this  
>>>> array of
>>>> points. Points on this array should be distributed *like* two crossing
>>>> functions as Sin[x] and Cos[x], but I don't know the functional form  
>>>> of
>>>> these functions.
>>>>
>>>> All that I have is an array of points!
>>>> Because of the fact that these points distribute on the x-y cartesian  
>>>> plane
>>>> like two crossing functions, I cannot use "joined->true" because it  
>>>> gives me
>>>> strange results.
>>>>
>>>> Thank you
>>>> Antonio
>>>> [...]
>>>
>>> One approach is to use Nearest to find candidate neighbors, then apply  
>>> a
>>> slope test to remove some contenders. For this purpose i adapted some
>>> code from a November thread.
>>>
>>> Our example:
>>>
>>> curves = Riffle[Table[{x, Sin[x]}, {x, 0., 2*Pi, .1}],
>>>     Table[{x, Cos[x]}, {x, .05, 2*Pi, .1}]];
>>>
>>> ListPlot[curves]
>>>
>>> Here is the code, with no attempt made to package it nicely. It gives  
>>> an
>>> imperfect rendering in this example. I think one could make more
>>> judicious of Nearest and also improve on the slope test, in a way that
>>> would give a more accurate picture of the two curves. But this is
>>> certainly a reasonable start.
>>>
>>> Needs["GraphUtilities`"];
>>>
>>> curvesmodif = curves /. {x_, y_} :> {x, y};
>>> nf = Nearest[curvesmodif];
>>> neighbors =
>>>    Map[{#, Complement[nf[#, 4], {#}]} &,
>>>      curvesmodif] /. {x_Real, y_Real} :> {x, y};
>>>
>>> Do[{elem, trio} = neighbors[[i]];
>>>   slopes = Map[(elem[[2]] - #[[2]])/(elem[[1]] - #[[1]]) &, trio];
>>>   slopes = Join[slopes, {slopes[[1]]}];
>>>   slopediffs = Differences[slopes];
>>>   bestpair = Ordering[Abs[slopediffs], 1][[1]];
>>>   neighbors[[i]] =
>>>    Sort[{elem, trio[[Mod[bestpair, 3, 1]]],
>>>      trio[[Mod[bestpair + 1, 3, 1]]]}];
>>>   , {i, Length[neighbors]}]
>>>
>>> graph = Union[
>>>     Flatten[Map[{#[[1]] -> #[[2]], #[[2]] -> #[[3]], #[[2]] -> #[[1]],  
>>> \
>>> #[[3]] -> #[[1]]} &, neighbors]]];
>>>
>>> Do[elem = graph[[i]];
>>>   If[! MemberQ[graph, Reverse[elem]], graph[[i]] = Null];,
>>>   {i, Length[graph]}]
>>> graph = graph /. Null :> Sequence[];
>>>
>>> pieces = WeakComponents[graph]
>>>
>>> plots = Map[ListPlot[#, Joined -> True] &, pieces];
>>>
>>>
>>> Daniel Lichtblau
>>> Wolfram Research
>>>
>>
>>
>
>


-- 
DrMajorBob at yahoo.com


  • Prev by Date: Re: Vectorized molecular dynamics with Mathematica?
  • Next by Date: Re: Vectorized molecular dynamics with Mathematica?
  • Previous by thread: Re: Joining points of ListPlot
  • Next by thread: Re: Joining points of ListPlot