5
$\begingroup$

I have different 3D graphics containing spheres, for example

pic1=Sphere[{0,0,0},1];
pic2={Sphere[{-1, 0, 0}, 1], Sphere[{1, 0, 0}, 1]};

I would like to show these in a Row:

Row[{Graphics3D[pic1, ImageSize -> Medium], Graphics3D[pic2, ImageSize -> Medium]}]

but in such a way that the spheres show with the same radius, instead of being magnified by Mathematica. What options do I have to adjust? Thanks for advice on this!

EDIT Thanks for the response so far, I try to be a bit more specific:
I want to "grow" icosahedra consisting of spheres, by adding layers, so I start with a sphere and put 12 spheres around it (the centers of these are forming an icosahedron). I repeat this several times (filling up the edges and faces accordingly).
What I want to achieve is several pictures next to each other, each with a new layer added. I have this so far:enter image description here
I would like to have the spheres the same size, though.

If you need to see the code, let me know.

$\endgroup$
  • $\begingroup$ Does it need to be Row? Grid or GraphicsGrid may offer more flexibility. Also, please define "same size". $\endgroup$ – Yves Klett Sep 3 '15 at 10:36
  • $\begingroup$ @YvesKlett Not necessarily, I was just following the example in reference.wolfram.com/language/ref/Sphere.html under "Applications". $\endgroup$ – cauchy42 Sep 3 '15 at 11:50
7
$\begingroup$

Calculating and specifying ImageSize are some kind of cumbersome. An easier way to do what OP asked would be using the same PlotRange for every plot.

The main idea is to plot all graphics with default options, then measure their actual PlotRange with the Charting`get3DPlotRange function described by Michael E2 in his this answer, from which we can then calculate the minimal PlotRange required to show every parts.

The code is as following.

centerSet = RandomReal[{-3, 3}, {5, 3}];
centerSetGrowing = Rest@FoldList[Join[#1, {#2}] &, {}, #] &@centerSet;
largestGraph3D = Graphics3D[Sphere[centerSetGrowing[[-1]], 1]];

largestRange = Charting`get3DPlotRange@largestGraph3D
g3dSet = Graphics3D[Sphere[{##}, 1], PlotRange -> largestRange] & @@@ centerSetGrowing

Mathematica graphics[1]

$\endgroup$
  • $\begingroup$ I look in awe upon your results, can you elaborate a bit on what is happening? $\endgroup$ – cauchy42 Sep 3 '15 at 13:05
  • $\begingroup$ @cauchy42 Basically I just find the largest PlotRange needed to show all the spheres in one plot -- in your case, that is the PlotRange of the last plot (so I should just write prange = Charting`get3DPlotRange[ g3dSet[[-1]] ] here), then you ask every plot to use this PlotRange instead of the automatic one. So now even for a plot with only, say, 1 sphere, you are using a PlotRange that can contain all 5 spheres. $\endgroup$ – Silvia Sep 3 '15 at 13:14
  • $\begingroup$ @cauchy42 I changed the code, hope it is more self-explained now. $\endgroup$ – Silvia Sep 3 '15 at 13:19
  • $\begingroup$ Yes, got it now. That way, I can even grow them sphere by sphere :) $\endgroup$ – cauchy42 Sep 3 '15 at 14:42
  • $\begingroup$ @cauchy42 you may consider changing the accepted answer. This solution is more versatile, no hardcoding involved. $\endgroup$ – Yves Klett Sep 5 '15 at 18:17
4
$\begingroup$

Using a specific projection I get this:

Row[{Graphics3D[{Opacity[.6], pic1}, ImageSize -> {Automatic, 200}, 
     PlotRangePadding -> None, ViewPoint -> {100, 100, 100}], 
    Graphics3D[{Opacity[.6], pic2}, ImageSize -> {Automatic, 200*5/4}, 
     PlotRangePadding -> None, ViewPoint -> {100, 100, 100}],
    Graphics3D[{Opacity[.6], pic3}, ImageSize -> {Automatic, 200*6/4}, 
     PlotRangePadding -> None, ViewPoint -> {100, 100, 100}]}]

Spheres of same size

This approach depends on the projection, i.e. if you want another ViewPoint the scaling factors change. Of course, all goes out the window if you start rotating freely with the mouse. In case of your icosahedron you need to know the size of the projected enclosing cube as function of the number of spheres and the view point to change my 5/4 and 6/4 accordingly. That should be doable, though.

$\endgroup$
3
$\begingroup$

Does it need to be using Row? The problem here is that the size of the sphere within the Graphics3D object depends upon the viewing point, viewing angle, etc. So even if you try to explicitly make the sizes of the two Graphics3D objects proportionally correct, you get this:

pic1 = Sphere[{0, 0, 0}, 1];
pic2 = {Sphere[{-1, 0, 0}, 1], Sphere[{1, 0, 0}, 1]};
Row[{Graphics3D[pic1, ImageSize -> 400],Graphics3D[pic2, ImageSize -> 800]}]

enter image description here

You'll have the same problem with GraphicsGrid, which in almost every case is better than Row.

Since you already have the objects in the same coordinate system, why not use Show instead of Row?

Show[Graphics3D /@ {pic1, pic2}]

enter image description here

But maybe you didn't want them to be overlapping? For placing 3D objects that are in the same coordinate system at specific spots relative to each other, Show is the way to go.

pic1 = Sphere[{0, 0, 0}, .5];
pic2 = {Sphere[{-1, 0, 0}, .5], Sphere[{1, 0, 0}, .5]};
Show[Graphics3D[{Magenta, pic1}, ImageSize -> Medium], 
Graphics3D[{Cyan, #}, ImageSize -> Medium] & /@ pic2, Boxed -> False,
  ImageSize -> 600]

enter image description here

$\endgroup$
  • $\begingroup$ Thanks for your response, please see my edited answer. I don't see if I can apply your last idea to achieve this. $\endgroup$ – cauchy42 Sep 3 '15 at 11:55
  • $\begingroup$ From your original question, it seemed that you wanted the individual spheres to be the same size. In that case, my answer or mikuszefski's answer would work. But from your edit, it seems that you want the entire group of spheres to be the same size. I would still opt for trying to plot them together in the same coordinate system, and display them using a single Show command. But that will be much more difficult, as in you would need to work the sphere sizes so that the total diameter is the same as the first sphere's diameter. $\endgroup$ – Jason B. Sep 3 '15 at 12:16
  • $\begingroup$ Sorry if unclear, I indeed want the individual spheres to be the same size (the overall pictures have the same size automatically). In your answer pic2 seems to be split in two parts, according to the colours. I don't see how I can achieve my goal with this. $\endgroup$ – cauchy42 Sep 3 '15 at 12:22
  • $\begingroup$ @cauchy42, I set the colors like that on purpose just to show what you can do - look at the code and it should be clear to just remove the color keywords. Go ahead and post the code you used to generate the 4 images and I will give it a go. $\endgroup$ – Jason B. Sep 3 '15 at 12:25
  • $\begingroup$ Thanks for your help, I finally got @mikuszefski's answer to work. I will add my code as an answer, just for comparison. $\endgroup$ – cauchy42 Sep 3 '15 at 12:39
2
$\begingroup$

@mikuszefski's idea of adjusting the overall height of the pictures, according to the number of spheres was very helpful. The diameter of an icosahedron with n shells (not counting the innermost sphere) is 2r(1+2n). Setting this as the image height, times a factor for magnification (here 150) produces this:enter image description here

Here's the code for this, there might be room for improvement in my usage of Mathematica :)

rad=0.5;
vc=PolyhedronData["Icosahedron","VertexCoordinates"];
vc2=2vc;
vc3=3vc;
neigh={{3,5,6,9,10},{4,7,8,11,12},{7,8,9,10},{5,6,11,12},{6,9,11},{10,12},{8,9,11},{10,12},{11},{12},{},{}};
faces={{1,3,9},{1,3,10},{1,5,6},{1,5,9},{1,6,10},{2,4,11},{2,4,12},{2,7,8},{2,7,11},{2,8,12},{3,7,8},{3,7,9},{3,8,10},{4,5,6},{4,5,11},{4,6,12},{5,9,11},{6,10,12},{7,9,11},{8,10,12}};
ed2=Table[Table[Sphere[(vc2[[j]]+vc2[[i]])/2,rad],{j,neigh[[i]]}],{i,1,12}];
ed3=Table[Table[{Sphere[1/3vc3[[j]]+2/3vc3[[i]],rad],Sphere[2/3vc3[[j]]+1/3vc3[[i]],rad]},{j,neigh[[i]]}],{i,1,12}];
fc3=Table[Sphere[(vc3[[i[[1]]]]+vc3[[i[[2]]]]+vc3[[i[[3]]]])/3,rad],{i,faces}];
lay0=Sphere[{0,0,0},rad];
lay1=Sphere[#,rad]&/@vc;
lay2=Flatten[{Sphere[#,rad]&/@vc2,ed2}];
lay3=Flatten[{Sphere[#,rad]&/@vc3,ed3,fc3}];
layvec={lay0,lay1,lay2,lay3};
p=Row[Table[Graphics3D[{Opacity[0.7],layvec[[1;;i]]}, Boxed->False,PlotRangePadding->0, ImageSize->{Automatic,150rad(1+2(i-1))}],{i,1,4}]]
$\endgroup$
  • $\begingroup$ This looks nice and I am glad that you put the code. You can avoid the double Table if you switch the order, i.e. Table[...,{i,1,12},{j,neigh[[i]]} ] should work. Note that you could have produced this image also with Jason-B's answer. However, that would have required to shift the coordinates of every cluster. With Map[] not so complicated though. $\endgroup$ – mikuszefski Sep 3 '15 at 13:57

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.