       Re: Joining points of ListPlot

• To: mathgroup at smc.vnet.net
• Subject: [mg117393] Re: Joining points of ListPlot
• From: Antonio Mezzacapo <ant.mezzacapo at gmail.com>
• Date: Thu, 17 Mar 2011 06:31:24 -0500 (EST)

```I like the use of FindClusters.

Antonio

2011/3/16 DrMajorBob <btreat1 at austin.rr.com>

> 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[] - #[])/(elem[] - #[]) &, trio];
> >>>   slopes = Join[slopes, {slopes[]}];
> >>>   slopediffs = Differences[slopes];
> >>>   bestpair = Ordering[Abs[slopediffs], 1][];
> >>>   neighbors[[i]] =
> >>>    Sort[{elem, trio[[Mod[bestpair, 3, 1]]],
> >>>      trio[[Mod[bestpair + 1, 3, 1]]]}];
> >>>   , {i, Length[neighbors]}]
> >>>
> >>> graph = Union[
> >>>     Flatten[Map[{#[] -> #[], #[] -> #[], #[] -> #[],
> >>> \
> >>> #[] -> #[]} &, 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: A bug in Partition?
• Next by Date: Re: Wolfram, meet Stefan and Boltzmann
• Previous by thread: Re: Joining points of ListPlot
• Next by thread: Question on Unevaluated