30
$\begingroup$

I have plotted a figure of MoS2 crytal structure. But the actual output looks like the spheres are not in the correct position due to the perspective effect.

I obtained the correct position figure by setting the ViewPoint to Infinity. But when I rotate the figure, the infinity effect fails and the perspective effect takes place again.

before and after rotation

I was wondering if there is a way to get rid of the perspective effect when you draw a graphic? Thank you.

Here is my code

a0 = 1; ceng = 1; znn =3*ceng; ynn = 5; xnn = 5; a1 = 2; cznn = 3; hh = 2;
p1[θ_] := RotationTransform[θ, {0, 0, 1}];
posx1 = (nx1 - 1) a0 + ((ny1 - 1) a0)/2 + (Mod[nz1 - 1, 3] a0)/2;
posy1 = Sqrt[3]/2 (ny1 - 1) a0 + (Sqrt[3] Mod[nz1 - 1, 3] a0)/6;
posz1 = Sqrt[3]/2 (nz1 - 1) a0 + Floor[(nz1 - 1)/3] a0;
sinpq2 = Transpose[Table[{posx1, posy1, posz1}, {ny1, ynn}, {nz1, znn}, {nx1, -xnn, 0}]];
rr = 0.3 a0;
tom2 = 
  Table[
    Graphics3D[{If[Mod[cc, 3] == 2, Pink, Yellow], Sphere[sinpq2[[cc, bb, aa]], rr]}], 
    {aa, xnn}, {bb, ynn}, {cc,znn}];
Show[tom2, 
  Axes -> False, 
  BoxStyle -> Directive[Orange, Opacity[0]],  
  BoxRatios -> Automatic, 
  PlotRange -> All, 
  Background -> Black,  
  ViewPoint -> {0, 0, ∞}]
Improve this question
$\endgroup$
5
  • $\begingroup$ possible duplicate of Switching among view points in a Manipulate expression $\endgroup$
    – m_goldberg
    Jul 15, 2013 at 10:08
  • 1
    $\begingroup$ this might be a duplicate of 3D plots with parallel projection - not quite sure what's required $\endgroup$
    – cormullion
    Jul 15, 2013 at 10:13
  • $\begingroup$ Try ViewPoint -> {0, 0, Dynamic[∞, None]} $\endgroup$
    – m_goldberg
    Jul 15, 2013 at 10:25
  • $\begingroup$ @cormullion closely related because OP here want to rotate an object. $\endgroup$
    – Kuba ♦
    Jul 15, 2013 at 10:39
  • $\begingroup$ @kuba Ah yes, I see - as soon as you start to rotate the viewpoint changes back to perspective. m_goldberg's solution doesn't work for me either... $\endgroup$
    – cormullion
    Jul 15, 2013 at 10:42

5 Answers 5

Reset to default
17
$\begingroup$

Maybe this will help a little (adapting documentation exaple for Slider2D):

 DynamicModule[{p = {2 π, 0}},
   Row @ {Slider2D[Dynamic[p], {{2 Pi, 0}, {0, Pi}}],
          Plot3D[Exp[-(x^2 + y^2)], {x, -3, 3}, {y, -3, 3}, 
            ImageSize -> {700, 700}, PlotRange -> All, ViewAngle -> .0015,
            ViewPoint -> Dynamic[1200 {Cos[p[[1]]] Sin[p[[2]]], 
                                       Sin[p[[1]]] Sin[p[[2]]], 
                                       Cos[p[[2]]]}
                         ]
          ]   
   }]

enter image description here

Notice that for parallel projection (like here) box edges do not seem to be parallel but they are and for default Mathematica display they are not but they look parallel

Improve this answer
$\endgroup$
6
  • $\begingroup$ +1 Cool! Very smooth control of object. Far better than the Mathematica default, in my view. $\endgroup$
    – DavidC
    Jul 15, 2013 at 11:13
  • $\begingroup$ It means I upvoted your entry. $\endgroup$
    – DavidC
    Jul 15, 2013 at 12:37
  • $\begingroup$ @DavidCarraher I thought so but something strange is happening to my rep and inbox lately. Good luck with Your project. $\endgroup$
    – Kuba ♦
    Jul 15, 2013 at 12:39
  • $\begingroup$ @Kuba This is awesome!! But can't help complaining about mma. $\endgroup$
    – matheorem
    Nov 8, 2015 at 15:32
  • $\begingroup$ @Kuba Could you please kindly comment the following. I cannot catch, where is in your code the part controlling the fact that the box edges are parallel? For the first glance it just looks like simply a nice rotation, though I see, indeed, the trick with the box edges you mention in the bottom of your answer. So, how did you achieve that? $\endgroup$
    – Alexei Boulbitch
    Nov 9, 2015 at 9:34
9
$\begingroup$

I think the only way to do this is by dynamically reseting the ViewMatrix to be an orthographic projection. It was beyond my ability, patience, or inclination to figure how to decompose the ViewMatrix that is created when the graphic is moved into the components ViewPoint, ViewVertical, etc. It seemed to me that the front end usually make a discontinuous jump from the view point in the orthographic projection to the initial view point in rotated graphic. Discouraged by this apparent behavior, I opted for a hybrid solution.

I used an ordinary Graphics3D with Dynamic view properties and used Inset to insert the graphics tom2 into it. The view properties of the outer Graphics3D are used to compute a corresponding orthographic projection ViewMatrix to be used to display the graphics tom2. So the mouse rotates the outer graphics and the code rotates the inset tom2 in the same way. The only difference is that tom2 is projected orthographically instead of perspectively.

To do this, I used and adapted code from Heike in this answer and Alexey Popkov in this answer. I needed Alexey Popkov's completePlotRange because AbsoluteOptions would not return the actual plot range.

(* Heike *)
theta[v1_] := ArcTan[v1[[3]], Norm[v1[[;; 2]]]];
phi[v1_] := If[Norm[v1[[;; 2]]] > .0001, ArcTan[v1[[1]], v1[[2]]], 0];
alpha[vert_, v1_] := ArcTan[{-Sin[phi[v1]], Cos[phi[v1]], 0}.vert, 
                             Cross[v1/Norm[v1], {-Sin[phi[v1]], Cos[phi[v1]], 0}].vert];
tt[v1_, vert_, center_, r_, scale_] := TransformationMatrix[
   RotationTransform[-alpha[vert/scale, v1], {0, 0, 1}] .
   RotationTransform[-theta[v1], {0, 1, 0}] .
   RotationTransform[-phi[v1], {0, 0, 1}] .
   ScalingTransform[r {1, 1, 1}] .
   TranslationTransform[-center]];

(* orthographic projection *)
pp = N@{{1, 0, 0, 1}, {0, 1, 0, 1}, {0, 0, -1, 0}, {0, 0, 0, 2}};

(* Alexey Popkov *)
completePlotRange[plot : (_Graphics | _Graphics3D)] := 
 Quiet@Last@
   Last@Reap[
     Rasterize[
      Show[plot, Axes -> True, Ticks -> (Sow[{##}] &), 
       DisplayFunction -> Identity], ImageResolution -> 1]]

(* OP *)
a0 = 1; ceng = 1; znn = 3*ceng; ynn = 5; xnn = 5; a1 = 2; cznn = 3; hh = 2;
p1[θ_] := RotationTransform[θ, {0, 0, 1}];
posx1 = (nx1 - 1) a0 + ((ny1 - 1) a0)/2 + (Mod[nz1 - 1, 3] a0)/2;
posy1 = Sqrt[3]/2 (ny1 - 1) a0 + (Sqrt[3] Mod[nz1 - 1, 3] a0)/6;
posz1 = Sqrt[3]/2 (nz1 - 1) a0 + Floor[(nz1 - 1)/3] a0;
sinpq2 = Transpose[Table[{posx1, posy1, posz1},
                         {ny1, ynn}, {nz1, znn}, {nx1, -xnn, 0}]];
rr = 0.3 a0;
(* updated - switched Graphics3D and Table, adjusted options *)
tom2 = Graphics3D[
   Table[{If[Mod[cc, 3] == 2, Pink, Yellow], Sphere[N@sinpq2[[cc, bb, aa]], rr]},
         {aa, xnn}, {bb, ynn}, {cc, znn}],
   Axes -> False, BoxStyle -> Directive[Orange, Opacity[1]], 
   BoxRatios -> Automatic, Background -> Black];

(* adapted from Heike *)
bb = completePlotRange@tom2;
scale = 1/Abs[#1 - #2] & @@@ bb;
center = Mean /@ bb;
vv = {Flatten[Differences /@ bb] + center, center};
v1 = (vv[[1]] - center);
vert = {0, 0, 1} - {0, 0, 1}.v1 v1;
viewAngle = 2 ArcCot[2.];

(* final graphic *)
Graphics3D[{},
 Epilog -> Inset[
   Show[tom2, 
        ViewMatrix ->
          Dynamic@{tt[v1, vert, center, Cot[viewAngle/2]/Norm[v1], scale], pp},
        PlotRange -> bb],
   Center, Center, 1],
 ViewAngle    -> Dynamic[viewAngle], 
 ViewVector   -> Dynamic[vv, (vv = #; center = vv[[2]]; v1 = vv[[1]] - center) &], 
 ViewVertical -> Dynamic[vert],
 SphericalRegion -> True, PlotRange -> bb, Boxed -> False]

Output after manual rotation:

Improve this answer
$\endgroup$
2
  • $\begingroup$ I'm sure you don't want to look at this code again... I'm seeing this error: i.stack.imgur.com/cHgNh.png $\endgroup$
    – cormullion
    Jul 16, 2013 at 22:49
  • $\begingroup$ I think it works now. $\endgroup$
    – Michael E2
    Jan 22, 2017 at 2:26
5
$\begingroup$

I just found the simplest solution.

Don't set ViewPoint to infinity!!! Just set it any number large enough, the effect will equivalent to setting to infinity.

Try for example the following

ListPointPlot3D[Tuples[Range[10], 3], BoxRatios -> Automatic, 
 ViewPoint -> {0, 0, 1000}]

for your example just change ViewPoint -> {0, 0, ∞} to ViewPoint -> {0, 0, 1000} or any number large than 1000 as you wish.

You'll be amazed at how simple it is to get rid of perspective. Rotate freely! : )

Improve this answer
$\endgroup$
1
  • $\begingroup$ Works for me, very cool! $\endgroup$
    – stiv
    Aug 13, 2016 at 10:11
4
$\begingroup$

Mathematica Version 11.2 affords the new option : ViewProjection-> "Orthographic".

It seems to do the job, but I can't test the interacitvity because I have only access to Mathematica 11.2 in the cloud (in the "Wolfram Development Platform").

So instead of interacting, I have set ViewPoint -> {0, 0, 3} in your example.

Here are the results : 

a0 = 1; ceng = 1; znn =3*ceng; ynn = 5; xnn = 5; a1 = 2; cznn = 3; hh = 2;
p1[\[Theta]_] := RotationTransform[\[Theta], {0, 0, 1}];
posx1 = (nx1 - 1) a0 + ((ny1 - 1) a0)/2 + (Mod[nz1 - 1, 3] a0)/2;
posy1 = Sqrt[3]/2 (ny1 - 1) a0 + (Sqrt[3] Mod[nz1 - 1, 3] a0)/6;
posz1 = Sqrt[3]/2 (nz1 - 1) a0 + Floor[(nz1 - 1)/3] a0;
sinpq2 = Transpose[Table[{posx1, posy1, posz1}, {ny1, ynn}, {nz1, znn}, {nx1, -xnn, 0}]];
rr = 0.3 a0;
tom2 = 
  Table[
    Graphics3D[{If[Mod[cc, 3] == 2, Pink, Yellow], Sphere[sinpq2[[cc, bb, aa]], rr]}], 
    {aa, xnn}, {bb, ynn}, {cc,znn}];


Show[tom2, 
  Axes -> False, 
  BoxStyle -> Directive[Orange, Opacity[0]],  
  BoxRatios -> Automatic, 
  PlotRange -> All, 
  Background -> Black,  
  ViewPoint -> {0, 0, 3}]


Show[tom2, 
  Axes -> False, 
  BoxStyle -> Directive[Orange, Opacity[0]],  
  BoxRatios -> Automatic, 
  PlotRange -> All, 
  Background -> Black,  
  ViewPoint -> {0, 0, 3},
  ViewProjection-> "Orthographic" (* <--- Here is the modification *)
  ]

enter image description here

It seems to work fine.

Improve this answer
$\endgroup$
1
  • $\begingroup$ I confirm it works fine, including interactivity, in normal desktop version of Mathematica 11.2 (Linux x86). $\endgroup$
    – Ruslan
    Sep 30, 2018 at 7:15
3
$\begingroup$

Combining some of the ideas here and elsewhere, this appears to produce a parallel projection:

tr = TransformationMatrix[
RescalingTransform[{{-2, 2}, {-2, 2}, {-3/2, 5/2}}]];
p = {{1, 0, 0, 0}, {0, 0, 1, 0}, {0, 1, 0, 0}, {0, 0, 0, 1}};
DynamicModule[{vm = {tr, p}, vp = {0, 0, 100}},
 tom2 = Table[
   Graphics3D[{If[Mod[cc, 3] == 2, Pink, Yellow], 
     Sphere[sinpq2[[cc, bb, aa]], rr]}, 
     ViewMatrix -> Dynamic[vm], 
     ViewPoint -> Dynamic[vp]], 
  {aa, xnn}, {bb, ynn}, {cc, znn}];
 Show[tom2, 
   Axes -> False, 
   BoxStyle -> Directive[Orange, Opacity[0]],
   BoxRatios -> Automatic, 
   PlotRange -> All, 
   Background -> Black]]

which you can test by looking at the columns of spheres end on - there's hardly any perspective at all:

a load of balls

Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ Rats, I was doing the same thing. If you change the opacity on the box, it's easier to see it's slightly off. The initial settings a reset on rotating the graphics to a perpective that is fairly far away. $\endgroup$
    – Michael E2
    Jul 16, 2013 at 13:33
  • 1
    $\begingroup$ @MichaelE2 Yes, it all seems more difficult than necessary. A nice ViewMode -> Cabinet or Cavalier would be cool. (Anyone know those? :) $\endgroup$
    – cormullion
    Jul 16, 2013 at 13:41
  • $\begingroup$ @cormullion The lattice changes size when rotating, can the size be fixed? $\endgroup$
    – matheorem
    Nov 8, 2015 at 15:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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