11
$\begingroup$

How can I prevent plotting functions from "connecting" inside a plot points that should "wrap around" outside the plot?

For example, how do I eliminate the horizontal lines running across the following ParametricPlot?

enter image description here

In this figure, the paths that reach the right hand end of the graph at 24 should continue at 0 (these are hours, so 24=0) without passing backwards across the figure.


Show[
 ParametricPlot[
  {AstronomicalData[
    "Mars", {"RightAscension", 
     DatePlus[Date[], d], {$GeoLocation[[1]] , $GeoLocation[[2]]}}], d},
  {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> Blue],
 ParametricPlot[
  {AstronomicalData[
    "Mercury", {"RightAscension", 
     DatePlus[Date[], d], {$GeoLocation[[1]] , $GeoLocation[[2]]}}], d},
  {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> Red],
 ParametricPlot[
  {AstronomicalData[
    "Jupiter", {"RightAscension", 
     DatePlus[Date[], d], {$GeoLocation[[1]] , $GeoLocation[[2]]}}], d},
  {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> Green]
 ]

FWIW, the (almost) final result, with help from SE: enter image description here

$\endgroup$
  • $\begingroup$ Note, this code is absurdly slow, but that's another question. $\endgroup$ – orome Oct 8 '12 at 3:43
  • $\begingroup$ Can't investigate at the moment (I suspect this is a matter of inverse trig branch cuts, though; see this), but: you can replace {$GeoLocation[[1]] , $GeoLocation[[2]]} with Take[$GeoLocation, 2]. $\endgroup$ – J. M. will be back soon Oct 8 '12 at 4:17
  • $\begingroup$ @J.M.: Good point. The code is adapted from cases where the latitude and longitude may be independently replaced, which is why that part is verbose. $\endgroup$ – orome Oct 10 '12 at 14:08
  • $\begingroup$ Related: (8576) $\endgroup$ – Mr.Wizard Jul 23 '15 at 20:37
5
$\begingroup$

Theoretically the Exclusions option should be able to handle this but I couldn't find the right arguments. Therefore I recommend a method similar to Simon's, but I would instead Split the lines where there are any large discontinuities in x :

(* Simon's code *)
plot = Show[MapThread[ParametricPlot[
 {AstronomicalData[#1, {"RightAscension", DatePlus[Date[], d], $GeoLocation}], d},
 {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> #2] &, 
 {{"Mars", "Mercury", "Jupiter"}, {Blue, Red, Green}}]];


plot /. Line[x_] :> Line@Split[x, Norm[# - #2] < 10 &]

Mathematica graphics

$\endgroup$
  • $\begingroup$ That certainly looks tidier than my CW answer. But I'm a bit foggy on what's going on with Line and :>. Is there a reason to prefer that approach over simply including the Split in the plot, as in the CW answer? $\endgroup$ – orome Oct 8 '12 at 23:52
  • $\begingroup$ Ah, I think I see the answer. My approach only works because I've "switched" to ListPlot, while this one works for any plot since it's operating on the Line primitive. (And yes, I tired Exclusions but could not get it to work.) $\endgroup$ – orome Oct 8 '12 at 23:55
  • 1
    $\begingroup$ @rax If you are not familiar with transformation rules you will need to start here. Specifically here the output of ParametricPlot is a Graphics object constructed of primitives such as Line and Options such as PlotRange. My transformation rule (applied with /.) is RuleDelayed (:>) so that the right-hand-side does not evaluate until x is substituted in. Norm is just a short-hand to check the distance between points; EuclideanDistance would work too, perhaps better. $\endgroup$ – Mr.Wizard Oct 9 '12 at 0:12
  • 1
    $\begingroup$ I used to use this precise strategy of Split[]-ting Line[] objects produced by plotting functions, for removing "long" or "steep" lines in plots, before the Exclusions option came along. I don't know about the advantages of rewriting the splitting test in terms of EuclideanDistance[], but Norm[# - #2] < 10 & is the same as EuclideanDistance[#, #2] < 10 &. $\endgroup$ – J. M. will be back soon Oct 9 '12 at 7:42
  • 1
    $\begingroup$ Ah, Split, much neater! I completely forgot about the existence of Split, even whilst thinking "I need to SPLIT this line into two"... $\endgroup$ – Simon Woods Oct 9 '12 at 9:14
4
$\begingroup$

A simple hack for this specific problem is to split each Line primitive into two at the first occurrence of a small x value:

plot = Show[MapThread[ParametricPlot[
 {AstronomicalData[#1, {"RightAscension", DatePlus[Date[], d], $GeoLocation}], d},
 {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> #2] &, 
 {{"Mars", "Mercury", "Jupiter"}, {Blue, Red, Green}}]];

plot /. Line[{pts1__, {x_ /; x < 1, _}, pts2__}] :> {Line[{pts1}], Line[{pts2}]}

enter image description here

$\endgroup$
3
$\begingroup$

This might be more simplistic than you were looking for but you could always just break it up into several sections and show them together

p1 = ParametricPlot[{AstronomicalData[
"Mars", {"RightAscension", 
 DatePlus[Date[], d], {$GeoLocation[[1]], $GeoLocation[[2]]}}], 
d}, {d, 155, 365}, AspectRatio -> 1/1.6, PlotStyle -> Blue, 
PlotRange -> All, AxesOrigin -> {0, 0}];

p2 = ParametricPlot[{AstronomicalData[
"Mars", {"RightAscension", 
 DatePlus[Date[], d], {$GeoLocation[[1]], $GeoLocation[[2]]}}], 
d}, {d, 0, 154}, AspectRatio -> 1/1.6, PlotStyle -> Blue, 
PlotRange -> All];

p3 = ParametricPlot[{AstronomicalData[
"Mercury", {"RightAscension", 
 DatePlus[Date[], d], {$GeoLocation[[1]], $GeoLocation[[2]]}}], 
d}, {d, 0, 186}, AspectRatio -> 1/1.6, PlotStyle -> Red];

p4 = ParametricPlot[{AstronomicalData[
"Mercury", {"RightAscension", 
 DatePlus[Date[], d], {$GeoLocation[[1]], $GeoLocation[[2]]}}], 
d}, {d, 187, 365}, AspectRatio -> 1/1.6, PlotStyle -> Red];

p5 = ParametricPlot[{AstronomicalData[
"Jupiter", {"RightAscension", 
 DatePlus[Date[], d], {$GeoLocation[[1]], $GeoLocation[[2]]}}], 
d}, {d, 0, 365}, AspectRatio -> 1/1.6, PlotStyle -> Green];

Show[p1, p2, p3, p4, p5]

enter image description here

Then you've changed the problem to writing a piece of code which detects the discontinuities and changes the indices in the plots accordingly. I don't have a chance to do that at the moment but something which measures the distance between successive x-co-ords which stops once the difference is more than a certain threshold you set would get the job done. Mightn't be efficient or tidy but you could generate your plots in an automatic way at least.

$\endgroup$
  • 1
    $\begingroup$ detecting the discontinuities could be done with something like this: mf[d_?NumericQ]:=AstronomicalData["Mars",{"RightAscension",DatePlus[Date[],d],{$GeoLocation[[1]],$GeoLocation[[2]]}}]; NMinimize[mf[d], {d, 150, 160}] $\endgroup$ – sebhofer Oct 8 '12 at 9:47
  • 1
    $\begingroup$ Or even FindMinimum[Abs@mf[d], {d, 155}], which is faster, but less robust and more dependent on well chosen initial conditions. $\endgroup$ – sebhofer Oct 8 '12 at 9:52
  • $\begingroup$ This won't help unless in includes a way to locate the spots that need to be excluded. For example, I'd like to put this into a Manipulate were I can change things like the date range dynamically. $\endgroup$ – orome Oct 8 '12 at 13:30
  • $\begingroup$ @raxacoricofallapatorius I suggested a way to do this! It might not be the most convenient and robust method though... $\endgroup$ – sebhofer Oct 8 '12 at 14:14
3
$\begingroup$

Using ListLinePlot with Mesh, MeshFunctions, MeshFunctions and MeshShading options. The idea is to change the color of portions to be excluded to White.

First, the data:

 {dataMars, dataMercury, dataJupiter} = 
   Table[{AstronomicalData[#, {"RightAscension", DatePlus[Date[], d], 
      $GeoLocation[[;; 2]]}], d}, {d, 0, 365}] & /@ {"Mars", "Mercury", "Jupiter"};

Next, a function to pick the jumps in the first column of the data that exceed a threshold:

ClearAll[pickJumpsF];
pickJumpsF = Function[{data, threshold},
   With[{maxdif = Max@Abs@Differences[First /@ data],
         range = Abs[(Max@# - Min@#) &@(First /@ data)]},
   If[maxdif <= threshold range, {},
      First@Pick[Most@data[[All, 2]], Abs@Differences[First /@ data], maxdif]]]];

where a jump is defined as a point where the difference between two consecutive elements is greater than threshold times the range of the list.

Applying pickJumpsF with a threshold parameter .8 to the three data sets:

meshpoints = Sort@Flatten@{#, # + 1} &[pickJumpsF[#, .8] & /@ 
   {dataMars, dataMercury, dataJupiter} /. {} ->  Sequence[]]
(* {154, 155, 186, 187} *)

Now, we can plot all three data sets in a single ListLinePlot:

ListLinePlot[{dataMars, dataMercury, dataJupiter}, 
 Mesh -> {meshpoints},
 MeshStyle -> None, MeshFunctions -> (#2 &), 
 MeshShading -> {Automatic, None},
 PlotStyle -> {Directive[Thick, Blue], Directive[Thick, Red], Directive[Thick, Green]},
 ImageSize -> 450]

enter image description here

$\endgroup$
2
$\begingroup$

The trick is to use Split in a ListPlot to introduce breaks into the data at the offending points:

Show[     
 ListPlot[
  Split[
   {astroData["RightAscension", "Mars", #, $GeoLocation], #} & /@ Range[0, 365],
   (Abs[#2[[1]] - #1[[1]]] < 20) &
   ], PlotStyle -> Blue, AspectRatio -> 1/1.6, Joined -> True],     
 ListPlot[
  Split[
   {astroData["RightAscension", "Mercury", #, $GeoLocation], #} & /@ Range[0, 365],
   (Abs[#2[[1]] - #1[[1]]] < 20) &
   ], PlotStyle -> Red, AspectRatio -> 1/1.6, Joined -> True],     
 ListPlot[
  Split[
   {astroData["RightAscension", "Jupiter", #, $GeoLocation], #} & /@ Range[0, 365],
   (Abs[#2[[1]] - #1[[1]]] < 20) &
   ], PlotStyle -> Green, AspectRatio -> 1/1.6, Joined -> True],     
 PlotRange -> {{0, 24}, {0, 365}}]

(Using a function, astroData, defined elsewhere to speed things up a bit.)

enter image description here


Update: While Split alone works for certain kinds of plots, it will not work for ListPlot, for which splitting will introduce a gap between the points where the lists are split, and the edges of the plot. This is not pronounced for steep lines, but is dramatic for shallow ones:

ListPlot[
 Split[
  {astroData["RightAscension", "Moon", #, $GeoLocation], #} & /@ Range[0, 365], 
  (Abs[#2[[1]] - #1[[1]]] < 20) &], 
 PlotStyle -> Black, AspectRatio -> 1/1.6, Joined -> True,
PlotRange -> {{0, 24}, {0, 365}}]

enter image description here

One way to overcome this is to "pad" the introduced gaps with "duplicates" of the points across the gap, shifted outside the edge of the plot. This can be done for arbitrary lists of data with something like

wrapDataList[data_, xmin_, xmax_, xgap_ ] :=
 Split[ 
  ReplaceRepeated[data, 
   {h___, {x1_, y1_}, {x2_, y2_}, t___} 
   /; (Abs[(x2 - x1)] > xgap && x2 >= xmin && x1 <= xmax) ->
     {h, {x1, y1}, {x2 + (xmax - xmin), y2}, {x1 - (xmax - xmin), y1}, {x2, y2}, t}],
  (#2[[2]] > #1[[2]]) & ]

which gives:

ListPlot[
 wrapDataList[
  {astroData["RightAscension", "Moon", #, $GeoLocation], #} & /@ Range[0, 365],
  0, 24, 20],
 PlotStyle -> Black, Joined -> True,
PlotRange -> {{0, 24}, {0, 365}}]

enter image description here

$\endgroup$
  • $\begingroup$ Since all of the answers (notably John's incomplete one) helped arrive at this, I'm making this CW. If someone wants to use this to improve their answer, I'll consider accepting that. Alternatively, please improve (or just vote up) this one so it can be taken as the answer. $\endgroup$ – orome Oct 8 '12 at 23:38
1
$\begingroup$

I don't how your data of each of your ParametricPlot looks like, but try to adapt the following:

Split[data, #1[[2]] != #2[[2]] &]
$\endgroup$
  • 2
    $\begingroup$ "I don't how your data of each of your ParametricPlot looks like..." - OP gave the code for producing the discontinuous plots. He wants the discontinuous plots to be made continuous, by stitching the two pieces together. $\endgroup$ – J. M. will be back soon Oct 8 '12 at 4:42
  • $\begingroup$ @J.M. I'm not familiar with AstronomicalData but maybe it is possible to produce the data via Table (i.e. wrapping AstronomicalData with Table) and then to use ListLinePlot with InterpolationOrder->3. $\endgroup$ – John Oct 8 '12 at 4:50
  • $\begingroup$ That won't cure the problem OP has; the function itself has a (spurious) discontinuity that needs to be remedied. See this similar question. $\endgroup$ – J. M. will be back soon Oct 8 '12 at 5:09
1
$\begingroup$

One way is to first use Clip to keep all differences between consecutive data points within a given range, then reconstruct the list using Accumulate:

dataMars =  Table[{d, AstronomicalData["Mars", {"RightAscension", 
 DatePlus[Date[], 
  d], {$GeoLocation[[1]], $GeoLocation[[2]]}}]}, {d, 0, 365}]

dataFixed[data_, minDiff_, maxDiff_] := With[{diff = Differences[data[[All, 2]]]}, 
  Transpose[{data[[All, 1]], Accumulate[
    Join[{data[[1, 2]]}, Clip[diff, {minDiff, maxDiff}]]]}]]

dataMars2 = dataFixed[dataMars, 0.0394, 0.0559];
dataMercury2 = dataFixed[dataMercury, -0.08668, 0.1493437];
dataJupiter2 = dataFixed[dataJupiter, -0.00969, 0.01664];

ListLinePlot[{dataMars2, dataMercury2, dataJupiter2}]

enter image description here

$\endgroup$
  • $\begingroup$ This isn't what the figure should look like. See my clarification and the figure in fizzics answer. $\endgroup$ – orome Oct 8 '12 at 13:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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