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, ∞}]
$\endgroup$
  • $\begingroup$ possible duplicate of Switching among view points in a Manipulate expression $\endgroup$ – m_goldberg Jul 15 '13 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 '13 at 10:13
  • $\begingroup$ Try ViewPoint -> {0, 0, Dynamic[∞, None]} $\endgroup$ – m_goldberg Jul 15 '13 at 10:25
  • $\begingroup$ @cormullion closely related because OP here want to rotate an object. $\endgroup$ – Kuba Jul 15 '13 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 '13 at 10:42
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

$\endgroup$
  • $\begingroup$ +1 Cool! Very smooth control of object. Far better than the Mathematica default, in my view. $\endgroup$ – DavidC Jul 15 '13 at 11:13
  • $\begingroup$ It means I upvoted your entry. $\endgroup$ – DavidC Jul 15 '13 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 '13 at 12:39
  • $\begingroup$ @Kuba This is awesome!! But can't help complaining about mma. $\endgroup$ – matheorem Nov 8 '15 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 '15 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:

$\endgroup$
  • $\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 '13 at 22:49
  • $\begingroup$ I think it works now. $\endgroup$ – Michael E2 Jan 22 '17 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! : )

$\endgroup$
  • $\begingroup$ Works for me, very cool! $\endgroup$ – stiv Aug 13 '16 at 10:11
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

$\endgroup$
  • 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 '13 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 '13 at 13:41
  • $\begingroup$ @cormullion The lattice changes size when rotating, can the size be fixed? $\endgroup$ – matheorem Nov 8 '15 at 15:38
3
$\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.

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

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.