Skip to main content

plotting - Combining 3 graphics of different coordinate systems


I have 3 graphics in different coordinate systems and I want to join them in as in the following figure. Sample Figure
This is just a sample figure, not the real one.


My functions are as follows.



y[t_]=Sin[Pi t]/(Pi t);
ar={1.415,2.495,3.526,4.462,5.421,6.477} (* Aproximate roots of y'[t] *);
rr=Join[{0},Table[t/.FindRoot[D[y[t],t]==0,{t,ar[[k]]}],{k,1,Length[ar]}],{7}] (* Real roots y'[t] *);
θ[t_]=Piecewise[Table[{ArcTan[y[t]/(t^2 y'[t])]+k Pi,rr[[k]]<=tρ[t_]=Sqrt[(y[t])^2 + (t^2 y'[t])^2] (* Amplitude function*) ;

The first graphic is generated by


p1=Plot[θ[t],{t,0,5},Ticks->{None,Table[{k π,k "π"}, {k,0,4}]},AxesLabel->{"t","θ"},AxesStyle->Directive[14],AxesOrigin->{0,0},PlotRange->Full]

p1



the second graphic is generated by


p2=Plot[y[t],{t,0,5},Ticks->{Table[{k,""},{k,1,5}],{1}},AxesLabel->{"t","y"},AxesStyle->Directive[14],AxesOrigin->{0,0},PlotRange->Full]

p2


the third and last one is generated by


p3=PolarPlot[ρ[t],{t,0,5},Ticks->None,AxesLabel->{"θ","ρ"},AxesStyle->Directive[14],AxesOrigin->{0,0}]

p3



Properties of the graphic is as follows.

1. Origins of p1 and p2 must be on the same vertical line, and the origins of p2 and p3 must be on the same horizontal line (as shown on the sample figure).
2. The horizontal lines passing at the points $\pi$, $2\pi$, $3\pi$, $4\pi$ located on the $\theta$-axis of p1 and the vertical lines passing at the zeros of the curve (which are explicitly $1,2,\cdots$ since $y(t)=\sin(\pi t)/(\pi t)=0$ at such points) in p2 must intersect on the curve in p1 (see the sample figure).
3.The list of extreme points of the curve in p2 are listed in rr, i.e., if $t$ is in rr then $y'(t)=0$ and thus $\rho(t)=|y(t)|$. For such points the distance from $t$-axis to the function $y$ in p2 is equal to the length from the Origin to the corresponding peak point of the curve in p3. This requires scaling of p3 so that the lengths are equal.


It would be very good to have them just in the right position, I guess I can draw the lines myself...


Many thanks.
bkarpuz



Edit. After reading Yves Klett's comment decided to show what I have tried. I did everything manually as I don't really understand the command Inset very well.


p1 = Plot[θ[t], {t, 0.7, 4.2}, Ticks -> {None, None}, 
   AxesLabel -> {"\!\(\*

StyleBox[\"t\",\nFontSlant->Italic]\)", "\!\(\*TagBox[
StyleBox[\"θ\",\nFontSize->14,\nFontSlant->Italic],
(StyleForm[#, 14, Italic]& )]\)"}, AxesStyle -> Directive[14], 
   AxesOrigin -> {0, 0}, PlotRange -> {{0, 4.5}, {0, 14}}, 
   AspectRatio -> 1];
p2 = Show[
   Plot[y[t], {t, 0.7, 4.2}, Ticks -> {Table[{k, ""}, {k, 1, 5}], {}},
     AxesLabel -> {"\!\(\*
StyleBox[\"t\",\nFontSlant->Italic]\)", "\!\(\*TagBox[
StyleBox[\"y\",\nFontSize->14,\nFontSlant->Italic],

(StyleForm[#, 14, Italic]& )]\)"}, AxesStyle -> Directive[14], 
    AxesOrigin -> {0, 0}, PlotRange -> {{0, 4.5}, {-2, 2}}, 
    AspectRatio -> 1], 
   ListPlot[Table[{rr[[k]], y[rr[[k]]]}, {k, 2, 4}], Filling -> Axis, 
    PlotStyle -> PointSize[Small]]];
pl = Table[{rr[[k]], ρ[rr[[k]]]}, {k, 2, 4}];
p3 = Show[
   PolarPlot[ρ[t], {t, 0.7, 4.2}, Ticks -> None, 
    AxesLabel -> {"θ", "ρ"}, AxesStyle -> Directive[14], 
    PlotStyle -> PointSize[Tiny], AspectRatio -> 1], 

   Table[ListPolarPlot[{{0, 0}, pl[[k]]}, Joined -> True, 
     PlotStyle -> {PointSize[Tiny], 
       Directive[Hue[0.67, 0.6, 0.6], Opacity[0.2]]}], {k, 1, 
     Length[pl]}], ListPolarPlot[pl]];

The figures are drawn above


Show[Graphics[{Inset[p2, {0, -0.35}, Right, 0.8], 
   Inset[p1, {0, 0.55}, Right, 0.8], 
   Inset[p3, {0.24, -0.415}, Left, 0.6]}, PlotRange -> 1], 
 Graphics[{Dotted, Line[{{-0.6215, -0.41}, {-0.6215, 0.3152}}], 

   Line[{{-0.4634, -0.41}, {-0.4634, 0.4762}}], 
   Line[{{-0.30515, -0.41}, {-0.30515, 0.6326}}]}], 
 Graphics[{Dotted, Line[{{-0.7778, 0.3152}, {-0.6215, 0.3152}}], 
   Line[{{-0.7778, 0.4762}, {-0.4634, 0.4762}}], 
   Line[{{-0.7778, 0.6326}, {-0.30515, 0.6326}}]}], 
 Graphics[{Point[{-0.6215, 0.3152}], Point[{-0.4634, 0.4762}], 
   Point[{-0.30515, 0.6326}]}], 
 Graphics[{Text[StyleForm["π", 14], {-0.8, 0.3152}, {1, 0}], 
   Text[StyleForm["2π", 14], {-0.8, 0.4762}, {1, 0}], 
   Text[StyleForm["3π", 14], {-0.8, 0.6326}, {1, 0}],}]]


I obtained all the points in the last part from the plain figure by Get Coordinates and drew the lines. On the other hand, to fit the Origins of p1 and p2, I drew them with Ticks->None and then put the Ticks manually on the figure obtained by Inset. However, the figure still seems to be inconvenient with p3 as it does not satisfy Property 3 (scaling) mentioned above.



Answer



Here I join 3 figures with lines in a tricky way, where I plot vertical and horizontal lines separately and set them by Inset at appropriate positions in such a way that the lines vanish when they touch the end figures.
Figure~1


y[t_] := Sin[π t]/(π t);
p[t_] = t^2;
a = 0.7;
b = 5.2;
yRoots = t /. {ToRules@Reduce[{y[t] == 0, 0 <= t <= 5}, t]};

yDRoots = t /. {ToRules@N@Reduce[{y'[t] == 0, 0 <= t <= 5}, y]};
ranges = Append[Prepend[yDRoots, 0], 6];
θ[t_] := Piecewise[Table[{ArcTan[y[t]/(p[t] y'[t])] + k Pi, ranges[[k]] < t <= ranges[[k + 1]]}, {k, Length@ranges - 1}]];
ρ[t_] := Sqrt[(y[t])^2 + (p[t] y'[t])^2];
ε = 1/(10^7);
p1 = Plot[θ[t], {t, a, b}, Ticks -> {None, Join[Table[{k Pi, k π}, {k, 0, 5}], Table[{(2 k - 1) Pi/2, (2 k - 1) Pi/2}, {k, 1, 5}]]}, AxesLabel -> {"t", "θ"}, AxesStyle -> Directive[14], AxesOrigin -> {0, 0}, PlotRange -> {{0, 5.3}, {0, 16}}, AspectRatio -> 1, ImagePadding -> 20, 
   Epilog -> {{Red, AbsolutePointSize@5, Point[{#, θ[#]}&/@yRoots]},
     {Blue, AbsolutePointSize@5, Point[{#, θ[#]}&/@(yDRoots + ε)]},
     {Black, AbsolutePointSize@5,Point[{{a, θ[a]}, {b, θ[b]}}]},
     {Gray, Dashed, Line[{{0, θ[#]}, {#, θ[#]}, {#, -100}}&/@yRoots], Line[{{0, θ[#]}, {#, θ[#]}}&/@yRoots]},

     {Gray, Dashed, Line[{{0, θ[#]}, {#, θ[#]}, {#, -100}}&/@(yDRoots+ε)]}}];
p2 = Plot[y[t], {t, a, b}, Ticks -> {Table[{k, ""}, {k, 1, 5}], {{1, ""}}}, AxesLabel -> {"t", "y"}, AxesStyle -> Directive[14], AxesOrigin -> {0, 0}, PlotRange -> {{0, 5.3}, {-0.3, 1}}, AspectRatio -> 1, ImagePadding -> 20, 
   Epilog -> {{Red, AbsolutePointSize@5, Point[{#, y[#]} & /@ yRoots]},
     {Blue, AbsolutePointSize@5, Point[{#, y[#]} & /@ yDRoots]},
     {Black, AbsolutePointSize@5, Point[{{a, y[a]}, {b, y[b]}}]},
     {Gray, Dashed, Line[{{#, 0}, {#, 100}} & /@ yRoots]},
     {Gray, Dashed, Line[{{100, y[#]}, {#, y[#]}, {#, 100}} & /@ yDRoots]}}];
p3 = ParametricPlot[{ρ[t] Cos[θ[t]], ρ[t] Sin[θ[t]]}, {t, a, b}, Ticks -> None, AxesLabel -> None, AxesStyle -> Directive[14], AxesOrigin -> {0, 0}, ImagePadding -> 20, PlotRange -> {{-6, 6}, {-0.3, 1}}, AspectRatio -> 1, 
   Epilog -> {{Red, AbsolutePointSize@5, Point[(ρ[#]*{Cos[θ[#]], Sin[θ[#]]})&/@yRoots]},
     {Blue, AbsolutePointSize@5,Point[(ρ[#]*{Cos[θ[#]], Sin[θ[#]]}) & /@ (yDRoots + ε)]},

     {Black, AbsolutePointSize@5, Point[{ρ[a]*{Cos[θ[a]], Sin[θ[a]]}, ρ[b]*{Cos[θ[b]], Sin[θ[b]]}}]},
     {Gray, Dashed,Line[{({-100, ρ[#]*Sin[θ[#]]}), (ρ[#]*{Cos[θ[#]],Sin[θ[#]]})}&/@(yDRoots + ε)]},
     {Gray, Dotted, Line[{{0, 0}, (ρ[a]*{Cos[θ[a]],Sin[θ[a]]})}]}}];
(* Vertical lines *)
pvl = Plot[2, {t, a, b}, Axes -> None, AxesOrigin -> {0, 0}, PlotRange -> {{0, 5.3}, {-1, 1}}, AspectRatio -> 1,  ImagePadding -> 20, 
   Epilog -> {{Gray, Dashed, Line[{{#, 0.66}, {#, 1}} & /@ yRoots]},
     {Gray, Dashed, Line[{{#, 0.66}, {#, 1}} & /@yDRoots]}}];
(* Horizontal lines *)
phl = Plot[2, {t, a, b}, Axes -> None, AxesOrigin -> {0, 0}, PlotRange -> {{0, 5.3}, {-0.3, 1}}, AspectRatio -> 1, ImagePadding -> 20, 
  Epilog -> {{Gray, Dashed, Line[{{0.03, y[#]}, {0.9, y[#]}} & /@yDRoots]}}];

(* Put the images together *)
Graphics[{Inset[p1, ImageScaled@{.05, 0.52}, {0, 0}, 1], 
  Inset[pvl, ImageScaled@{.05, .31}, {0, 0}, 1], 
  Inset[p2, ImageScaled@{.05, .12}, {0, 0}, 1], 
  Inset[phl, ImageScaled@{.48, .12}, {0, 0}, 1], 
  Inset[p3, ImageScaled@{.77, .12}, {0, 0}, 1]}, ImageSize -> 800, PlotRange -> All]

Using GraphicsGrid this can be done easier as follows by replacing the code under the last comments in the above with the following.


GraphicsGrid[{{p1,Null,Null},{pvl,Null,Null},{p2,phl,p3}},ImageSize->600,Spacings->-66]


Thank you for the interest, and any other solutions are welcome.
bkarpuz


Comments

Post a Comment

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...
Post a Comment
Read more