Re: Joining points of ListPlot
- To: mathgroup at smc.vnet.net
- Subject: [mg117351] Re: Joining points of ListPlot
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Wed, 16 Mar 2011 06:25:14 -0500 (EST)
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