Re[2]: ListPlot mit unterschiedlichen Achsen links und rechts

["Udo und Susanne Krause" <su.krause@XXXXXXX.ch>]

Hallo Martin

Hier ist eine Funktion, die zwei Plots mit je einer Funktion (genauer  
gesagt, mit einer datentragenden Line[] im zweiten Plot) mittels einer  
affinen Transformation nach Massgabe des ersten Plots zusammenführt und  
mit der inversen affinen Transformation die Ticks ausrechnet.

In[99]:= Remove[heimannCombiPlot];
heimannCombiPlot[g1_Graphics, g2_Graphics] :=
 Module[{liC1 = Line[{}], liC2 = Line[{}], ploR1, ploR2, xTix = {},
   yTix = {},
   xtv = {}, ytv = {}},
  (* line complexes *)
  If[o = Position[InputForm[FullGraphics[g1]], _Line]; Length[o] > 0,
   liC1 = Part[InputForm[FullGraphics[g1]], Sequence @@ First[o]]
   ];
  If[o = Position[InputForm[FullGraphics[g2]], _Line]; Length[o] > 0,
   liC2 = Part[InputForm[FullGraphics[g2]], Sequence @@ First[o]]
   ];
  (* no data exit *)
  If[ Length @@ liC1 == 0 || Length @@ liC2 == 0,
   Print["At least one of the graphics contains an empty or no Line[] \
to transform."];
   Return[Show[{g1, g2}, Frame -> True]] (* Ciao bella *)
   ];
  ploR1 = FullOptions[g1, PlotRange];
  ploR2 = FullOptions[g2, PlotRange];
  (* affine transformation *)
  m1 = Dot[{-1, 1}, First[ploR1]]/Dot[{-1, 1}, First[ploR2]];
  m2 = Dot[{-1, 1}, Last[ploR1]]/Dot[{-1, 1}, Last[ploR2]];
  (* operational order does matter for the affine shift *)
  v = ((Dot[{1, 1}, #]& /@ ploR1) -
      DiagonalMatrix[{m1, m2}] . (Dot[{1, 1}, #]& /@ ploR2))/2.;
  (* Print[" Affin: ", DiagonalMatrix[{m1, m2}], v]; *)
  (* tick computation *)
  If[ And @@ FullOptions[g1, Frame],
   xTix =
    First /@ (Part[FullOptions[g1, FrameTicks], Sequence @@ #]& /@
       Cases[Position[
         FullOptions[g1,
          FrameTicks], {_Real, _Real, __List}], {1, _}]);
   yTix =
    First /@ (Part[FullOptions[g1, Ticks], Sequence @@ #]& /@
       Cases[Position[
         FullOptions[g1, Ticks], {_Real, _Real, __List}], {2, _}]), (*  
else *)
   xTix =
    First /@ (Part[FullOptions[g1, Ticks], Sequence @@ #]& /@
       Cases[Position[
         FullOptions[g1, Ticks], {_Real, _Real, __List}], {1, _}]);
   yTix =
    First /@ (Part[FullOptions[g1, Ticks], Sequence @@ #]& /@
       Cases[
        Position[
         FullOptions[g1, Ticks], {_Real, _Real, __List}], {2, _}]);
   ];
  xtv = Transpose[{xTix , Table[0, {Length[xTix]}]}];
  ytv = Transpose[{Table[0, {Length[yTix]}], yTix}];
  xtv = Dot[DiagonalMatrix[{1/m1, 1/m2}], #]& /@  (Plus[-v, #]& /@
      xtv );
  ytv = Dot[DiagonalMatrix[{1/m1, 1/m2}], #]& /@ (Plus [-v, #]& /@
      ytv );
  Show[{g1, Graphics[GeometricTransformation[liC2,
      AffineTransform[{DiagonalMatrix[{m1, m2}], v}]]]},
   Frame -> True,
   FrameLabel -> {{y, Y}, {x, X}},
   FrameTicks -> {{Automatic,
      Transpose[{yTix, ytv[[All, 2]]}]}, {Automatic,
      Transpose[{xTix, xtv[[All, 1]]}]}},
   PlotRange -> All]
  ]

mit den Daten von gestern

> g1 = Graphics[{Pink, Disk[{-1, 0}, {3, 1}, {0.393, (2 - 0.393)}  Pi]}];
> g2 = Graphics[{Blue, Disk[{0, 0}, 0.05]}];

passiert nix weiter,

In[101]:= heimannCombiPlot[g1, g2]

"At least one of the graphics contains an empty or no Line[] to \
transform.".

Mit
In[39]:= Clear[p1];
p1 = Plot[Sin[x + Cos[x]] -  Cos[x - Sin[x]], {x, 0, 2 Pi}]

und
In[108]:= Clear[p2];
p2 = Plot[
  2 (-Pi + Sin[2 x - Cos[x]] + 2 Cos[x + Sin[x]]), {x, -4 Pi, 0}]

gibt
In[110]:= heimannCombiPlot[p1, p2]

das Bildchen im Anhang. Sie könnten eine Erweiterung vornehmen für den  
Fall, dass g2 mehrere Funktionsgraphen enthält (liC1 braucht man nicht, by  
the way). Man müsste noch Tests machen, falls g1 gar keine Ticks hat, was  
dann passiert. Und - wie immer - alles nachrechnen.

Gruss
Udo.

--
Using Opera's revolutionary e-mail client: http://www.opera.com/mail/

heimannCombiPlot.jpeg
Description: JPEG image