Skip to main content

graphics3d - How to avoid the wiggly text on Ticks and Labels when rotating 3D objects


Motivation



I'm trying to do a nice animation of the rotation of a ParametricPlot3D . My problem is that the Ticks numbers and AxesLabel text wiggle with an undesirable noisy component as the ViewPoint changes.


Rotating ParametricPlot3D


Questions


How can I figure out why it wiggles?


How do I avoid it?


I'm guessing that there is some "round up to nice values" going on somewhere, but the output of TracePrint its not too revealing to me.


Code


examplePlot = ParametricPlot3D[
  Evaluate@Table[
    {

     k
     , s
     , Sin[k s] + k s/50
     }
    , {k, 7}
    ]
  , {s, 0, 4 Pi}
  , PlotRange -> {{-2, 4 Pi}, {0, 4 Pi}, {-2, 4}}
  , BoxRatios -> {1, 3, 1}
  , PlotStyle -> Array[Hue, 7, {0, 0.75}]

  , PlotPoints -> 150
  , MaxRecursion -> 5
  , BaseStyle -> {FontSize -> 14, FontFamily -> "Helvetica", 
    FontTracking -> "Plain", TextJustification -> 0, 
    PrivateFontOptions -> {"OperatorSubstitution" -> False}}
  , ImageSize -> {700, 300}
  , ViewAngle -> 0.19
  , Ticks -> {Range[7], Automatic, Automatic}
  ]


animExample = Table[
   Show[
    examplePlot
    , ViewPoint -> {3, 0.4 + 0.5 Sin[j], 0.5 + 0.2 Cos[j]}
    , RotationAction -> "Clip"
    , ViewVertical -> {0, 0, 1}
    , ViewAngle -> 0.22
    , AxesEdge -> {{1, -1}, Automatic, {1, -1}}
    , AxesLabel -> {"Axis 1", "Axis 2", "Axis 3"}
    ]

   , {j, 0, 2 π, π/25}];

Export["animExample.GIF", animExample, "DisplayDurations" -> 0.15, 
 "AnimationRepetitions" -> Infinity]

Answer



Not a complete answer, but I think this can get you close to the solution.


If you use images instead of text, there's less (or even no) jumping around. I only worked on the ticks.


To have the ticks numbers rasterized, I made a variation of this, but there's probably a simpler way (I didn't try to put your ticks specification, but it should be easy).


Then, I played with the sizes and resolutions, and my end result still needs a lot of tuning: line thickness / darkness are a little lost in rasterings and resizings, numbers are flickering (but I do believe that they are not jumping; you tell me...)


enter image description here



I hope this helps as a start:


tickF[div1_, div2_: - 1] := (If[div2 == -1, 
    Thread[{#, #, {.02, 0}}, List, 2] &@FindDivisions[{#1, #2}, div1],
     Join @@ 
     MapAt[Join @@ # &, {Function[{p}, {p, 
            Magnify[Rasterize[p, RasterSize -> 150], 3], {.02, 
             0}}] /@ #[[1]], 
         Thread[{#, "", {.01, 0}}, List, 2] & /@ #[[2]]} &@
       FindDivisions[{#1, #2}, {div1, div2}], {2}]]) &



examplePlot[j_] := 
 ParametricPlot3D[
  Evaluate@Table[{k, s, Sin[k s] + k s/50}, {k, 7}], {s, 0, 4 Pi}, 
  PlotRange -> {{-2, 4 Pi}, {0, 4 Pi}, {-2, 4}}, 
  BoxRatios -> {1, 3, 1}, PlotStyle -> Array[Hue, 7, {0, 0.75}], 
  PlotPoints -> 150, MaxRecursion -> 5, 
  BaseStyle -> {FontSize -> 14, FontFamily -> "Helvetica", 
    FontTracking -> "Plain",
    TextJustification -> 0, 

    PrivateFontOptions -> {"OperatorSubstitution" -> False}}, 
  ImageSize -> {3*700, 3*300},
  Ticks -> 
   Evaluate@({(t1 = {##}; tickF[8, 5][##]) &, (t2 = {##}; 
        tickF[8, 5][##]) &, (t3 = {##}; N /@ tickF[8, 5][##]) &}),
  ViewPoint -> {3, 0.4 + 0.5 Sin[j], 0.5 + 0.2 Cos[j]},
  RotationAction -> "Clip",
  ViewVertical -> {0, 0, 1},
  ViewAngle -> 0.22,
  AxesEdge -> {{1, -1}, Automatic, {1, -1}},

  AxesLabel -> {"Axis 1", "Axis 2", "Axis 3"}];

animExample = 
 Table[ImageResize[Rasterize[examplePlot[j], "Image"], 700], {j, 0, 2 \[Pi], \[Pi]/25}];

EDIT


Still based on rasterization, but better looking:


enter image description here


tickF[div1_, 
  div2_: - 1] := (If[div2 == -1, 

    Thread[{#, #, {.02, 0}}, List, 2] &@FindDivisions[{#1, #2}, div1],
     Join @@ 
     MapAt[Join @@ # &, {Function[{p}, {p, p, {.02, 0}}] /@ #[[1]], 
         Thread[{#, "", {.01, 0}}, List, 2] & /@ #[[2]]} &@
       FindDivisions[{#1, #2}, {div1, div2}], {2}]]) &

examplePlot[j_, factor_] := 
 ImageResize[
  Rasterize[
   ParametricPlot3D[

    Evaluate@Table[{k, s, Sin[k s] + k s/50}, {k, 7}], {s, 0, 4 Pi}, 
    PlotRange -> {{-2, 4 Pi}, {0, 4 Pi}, {-2, 4}}, 
    BoxRatios -> {1, 3, 1}, 
    PlotStyle -> Array[{Hue[#], Thickness[0.006]} &, 7, {0, 0.75}], 
    PlotPoints -> 150, MaxRecursion -> 5, 
    BaseStyle -> {FontSize -> factor*14, FontFamily -> "Helvetica", 
      FontTracking -> "Plain",
      TextJustification -> 0, 
      PrivateFontOptions -> {"OperatorSubstitution" -> False}}, 
    ImageSize -> {factor*700, factor*300},

    ViewPoint -> {3, 0.4 + 0.5 Sin[j], 0.5 + 0.2 Cos[j]},
    RotationAction -> "Clip",
    ViewVertical -> {0, 0, 1},
    ViewAngle -> 0.22,
    AxesEdge -> {{1, -1}, Automatic, {1, -1}},
    AxesLabel -> {"Axis 1", "Axis 2", "Axis 3"},
    Ticks -> 
     Evaluate@({(t1 = {##}; tickF[8, 5][##]) &, (t2 = {##}; 
          tickF[8, 5][##]) &, (t3 = {##}; N /@ tickF[8, 5][##]) &}),
    BoxStyle -> Directive[Thickness[0.003]]

    ], "Image", RasterSize -> 4000], 700, Resampling -> "Linear"]


animExample6 = Table[examplePlot[j, 6], {j, 0, 2 \[Pi], \[Pi]/25}];
Export["animExample.GIF", animExample6, 
 "DisplayDurations" -> 0.15, "AnimationRepetitions" -> Infinity]

(not sure if factor is doing that much... but at least it is better looking, simpler and faster)


Comments

Post a Comment

Popular posts from this blog

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

equation solving - Invert and fit implicitly defined curve

I need to fit an implicitly defined curve. I thought I could get some data out of Solve , and then using FindFit . Therefore, I would like to find the relation the parametric curve defined by $F(x,y)=0$: Solve[-(1/2) + 1/2 (0.41202 BesselK[0, 0.1 Sqrt[x^2 + y^2]] + (0.101483 x BesselK[1, 0.1 Sqrt[x^2 + y^2]])/Sqrt[x^2 + y^2]) == 0, y] But I can't get an output: Solve was unable to solve the system with inexact coefficients or the system obtained by direct rationalization of inexact numbers present in the system. Since many of the methods used by Solve require exact input, providing Solve with an exact version of the system may help. >> Edit: In particular, I would like to fit the data coming from the curve with the expression of another curve, and not with a function $f(x)$. In particular, since this clearly looks like a cardioid , I would like it to fit to something like it. What other strategies could I try?
Post a Comment
Read more

dynamic - How can I make a clickable ArrayPlot that returns input?

I would like to create a dynamic ArrayPlot so that the rectangles, when clicked, provide the input. Can I use ArrayPlot for this? Or is there something else I should have to use? Answer ArrayPlot is much more than just a simple array like Grid : it represents a ranged 2D dataset, and its visualization can be finetuned by options like DataReversed and DataRange . These features make it quite complicated to reproduce the same layout and order with Grid . Here I offer AnnotatedArrayPlot which comes in handy when your dataset is more than just a flat 2D array. The dynamic interface allows highlighting individual cells and possibly interacting with them. AnnotatedArrayPlot works the same way as ArrayPlot and accepts the same options plus Enabled , HighlightCoordinates , HighlightStyle and HighlightElementFunction . data = {{Missing["HasSomeMoreData"], GrayLevel[ 1], {RGBColor[0, 1, 1], RGBColor[0, 0, 1], GrayLevel[1]}, RGBColor[0, 1, 0]}, {GrayLevel[0], GrayLevel...
Post a Comment
Read more