Display multiple 2D plots in 3D using Graphics in Mathematica? - graphics

Considering the following :
lalist = {{{{1, 1}, 1}, {{3, 3}, 1}, {{5, 5}, 1}},
{{{1, 5}, 1}, {{3, 3}, 1}, {{5, 1}, 1}}}
Row[{
Graphics[{
Opacity[0.5],Red,
Disk ### lalist[[1]]},
Frame -> True],
Graphics[{
Opacity[0.5],Blue,
Disk ### lalist[[2]]},
Frame -> True]}
]
Is it possible that I plot the Blues
Disks "behind" the red ones in a 3 D
plot ?
Below is not what I need :

Like this?
Graphics3D[{{Texture[
Graphics[{Opacity[0.5], Blue, Disk ### lalist[[2]]},
Frame -> True]],
Polygon[{{-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}},
VertexTextureCoordinates \[Rule] {{0, 0}, {1, 0}, {1, 1}, {0,
1}}]}, {Texture[
Graphics[{Opacity[0.5], Red, Disk ### lalist[[1]]},
Frame -> True]],
Polygon[{{-1, -1, 1}, {1, -1, 1}, {1, 1, 1}, {-1, 1, 1}},
VertexTextureCoordinates \[Rule] {{0, 0}, {1, 0}, {1, 1}, {0,
1}}]}}, Lighting \[Rule] "Neutral"]
Lots of them with opacity .2:
tab = Table[{Opacity \[Rule] .2,
Texture[Graphics[{Opacity[0.5], Blue, Disk ### lalist[[2]]},
Frame -> True]],
Polygon[{{-1, -1, z}, {1, -1, z}, {1, 1, z}, {-1, 1, z}},
VertexTextureCoordinates \[Rule] {{0, 0}, {1, 0}, {1, 1}, {0,
1}}]}, {z, -2, 2, 1}];
plt = Graphics3D[{tab}, Lighting \[Rule] "Neutral"]
and 400 don't seem to be much of a problem in terms of speed (you can easily modify the code above to see it).
EDIT: OK, just to be silly, try this
Dynamic[Graphics3D[{{Texture[#],
Polygon[{{-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}},
VertexTextureCoordinates \[Rule] {{0, 0}, {1, 0}, {1, 1}, {0,
1}}]}, {Texture[Rotate[#, \[Pi]/2]],
Polygon[{{-1, -1, 1}, {1, -1, 1}, {1, 1, 1}, {-1, 1, 1}},
VertexTextureCoordinates \[Rule] {{0, 0}, {1, 0}, {1, 1}, {0,
1}}]}}, Lighting \[Rule] "Neutral"] &#Binarize[CurrentImage[]]]
which gives
(or something like that), rotatable, updated in real time etc.

See the solution presented on "Lunchtime Playground: Fun with Mathematica" here: http://mathgis.blogspot.com/2009/02/howto-display-2d-plot-in-3d.html

Using transparent textures to render these circles in layers as ACL does is a nice solution, unless one wants to interact with the resulting 3D object. Rendering of 3D objects that contain transparent elements is done in software whereas otherwise it would have been done in hardware:
The 3D renderer uses two different
methods of sorting polygons. For
graphics scenes that include no
transparency, a hardware-accelerated
depth buffer is used. Otherwise, the
renderer uses a binary space partition
tree to split and sort polygons from
any viewpoint. The BSP tree is slower
to create and is not hardware
accelerated, but it provides the most
general ability to support polygons.
On my laptop, interaction with 3D graphics is incredibly slow as soon as transparent objects start to appear.
The solution would be to use 3D disks instead of semi transparent planes with 2D disks in them. Since MMA doesn't have 3D Disks or Circles if you want to do something like that, you have to roll your own. A bare-bones version would be something like:
myDisk[{x_, y_, z_}, r_] :=
Polygon#Table[
{x, y, z} + r {Cos[\[Phi]], Sin[\[Phi]], 0} // N,
{\[Phi], 0, 2 \[Pi], 2 \[Pi]/200}
]
Your layers would then be generated as follows:
Graphics3D[
{
EdgeForm[],
{
Red,
myDisk[{1, 1, 0.5}, 0.5],
myDisk[{0, 0, 0.5}, 0.5],
myDisk[{-1, -1, 0.5}, 0.5]
},
{
Blue,
myDisk[{1, -1, -0.5}, 0.5],
myDisk[{0, 0, -0.5}, -0.5],
myDisk[{-1, 1, -0.5}, 0.5]}
}
]

Related

Drawing clock face in Mathematica (looking for a better solution)

I am trying to find a general solution for drawing clock face like graphical objects in Mathematica. I've already implemented a version of my own, but I think a much better solution must exist. A neater version with less code or clearer thought process would be appreciated.
My version:
radius = 1;
elementList =
Join[Table[i, {i, 3, 1, -1}], Table[i, {i, 12, 4, -1}]];
elementNumber = Length[elementList];
thetaList = Table[i, {i, 0, 2 Pi, 2 Pi/elementNumber}][[1 ;; 12]];
coordinateList = Map[{radius*Cos[#], radius*Sin[#]} &, thetaList];
objectList =
Map[Style[#, FontFamily -> "Georgia", FontSize -> 30] &,
elementList];
Graphics[
Join[
MapThread[Text[#1, #2] &, {objectList, coordinateList}],
{Circle[{0, 0}, 1.2*radius]}
]
]
Here is one way to make a clock:
clockFace = Import["http://i.imgur.com/ufanv.jpg"];
{hour, minute, second} = Take[Date[], -3];
hour = Mod[hour, 12] + minute/60.;
Graphics3D[
{
{Texture[clockFace],
Polygon[{{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}},
VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}
]
},
{Black, AbsoluteThickness[8],
Line[{{0, 0, 0},
.55 {Cos[Pi/2 - 2 Pi hour/12], Sin[Pi/2 - 2 Pi hour/12], 0}}
]
},
{Black, AbsoluteThickness[5],
Line[{{0, 0, 0},
.8 {Cos[Pi/2 - 2 Pi minute/60], Sin[Pi/2 - 2 Pi minute/60], 0}}
]
}
},
Boxed -> False, Lighting -> "Neutral"]
Addition
Here is a rotating, spinning 3D clock for your amusement:
clockFace = Import["http://i.imgur.com/ufanv.jpg"];
vtc = VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}};
hand[thickness_, radius_, time_] := {AbsoluteThickness[thickness],
Line[{{0, 0, -1}, {radius Cos[Pi/2 + 2 Pi time],
radius Sin[Pi/2 + 2 Pi time], -1}}],
Line[{{0, 0, 1}, {radius Cos[Pi/2 - 2 Pi time],
radius Sin[Pi/2 - 2 Pi time], 1}}],
Line[{{0, -1, 0}, {radius Cos[Pi/2 - 2 Pi time], -1,
radius Sin[Pi/2 - 2 Pi time]}}],
Line[{{0, 1, 0}, {radius Cos[Pi/2 + 2 Pi time], 1,
radius Sin[Pi/2 + 2 Pi time]}}],
Line[{{-1, 0, 0}, {-1, radius Cos[Pi/2 + 2 Pi time],
radius Sin[Pi/2 + 2 Pi time]}}],
Line[{{1, 0, 0}, {1, radius Cos[Pi/2 - 2 Pi time],
radius Sin[Pi/2 - 2 Pi time]}}]};
Dynamic[
{hour, minute, second} = Take[Date[], -3];
hour = Mod[hour, 12] + minute/60.;
Graphics3D[{
{Texture[clockFace],
Polygon[{{1, -1, -1}, {-1, -1, -1}, {-1, 1, -1}, {1, 1, -1}},
vtc],
Polygon[{{-1, -1, 1}, {1, -1, 1}, {1, 1, 1}, {-1, 1, 1}}, vtc],
Polygon[{{-1, 1, -1}, {-1, -1, -1}, {-1, -1, 1}, {-1, 1, 1}},
vtc], Polygon[{{1, -1, -1}, {1, 1, -1}, {1, 1, 1}, {1, -1, 1}},
vtc], Polygon[{{-1, -1, -1}, {1, -1, -1}, {1, -1, 1}, {-1, -1,
1}}, vtc],
Polygon[{{1, 1, -1}, {-1, 1, -1}, {-1, 1, 1}, {1, 1, 1}}, vtc]
}, {Black,
hand[8, .55, hour/12],
hand[5, .8, minute/60],
hand[3, .8, second/60]
}
},
Boxed -> False, Lighting -> "Neutral",
ViewPoint ->
5 {Cos[2 Pi second/60], Sin[2 Pi second/60],
Sin[2 Pi second/30]}, SphericalRegion -> True,
Background -> Black, ImageSize -> Full]] // Deploy
Here's a version of a function that generalizes the generation of clock face to allow you to easily change the style of the numbers, the number of "hours", and the radius of the face:
Options[clockFace] = {FontFamily -> "Georgia", FontSize -> 30};
clockFace[hours_Integer, radius_?NumericQ, opts : OptionsPattern[]] /;
hours > 0 && Im[radius] == 0 && radius > 0 :=
With[{range = Range[12]},
With[{objects =
Style[#,
FilterRules[{opts}, Options[Style]] ~Join~ Options[clockFace]] & /# range,
thetas = Pi/2 - 2 Pi*range/hours},
Graphics[Append[
MapThread[Text[#1, {Cos[#2], Sin[#2]}] &, {objects, thetas}],
Circle[radius*1.2]]]]]
Some things are just Mathematica style issues; for instance,
FilterRules[{opts}, Options[Style]] ~Join~ Options[clockFace]
is just the way to pass the relevant optional arguments to Style while making sure that clockFace's default values are used where relevant, because Mathematica will use the first applicable rule that it finds in a list of rules (and function options are just lists of rules). I also used With to name things, which is why there's that nesting; other people might prefer to use a single Module. Either way, it's always best to make things local variables whenever possible.
The biggest change, though, was generating the list of numbers in order, using Range, and then adjusting the definition of thetas so everything winds up in the right place. I think it's much easier to see what's going on, because the minus sign means you're moving around clockwise and offsetting by Pi/2 makes it clear you're starting at the top of the clock.
The following is a working 3D clock made by easily combining #Arnoud's answer with Christopher's blog entry:
makeHand[fl_, bl_, fw_, bw_] :=
Polygon[{{-bw, -bl, 0.1}, {bw, -bl, 0.1}, {fw, fl, 0.1},
{0, fl + 8 fw, 0.1}, {-fw, fl, 0.1}}/9];
hourHand = makeHand[5, 5/3, .1, .3];
minuteHand = makeHand[7, 7/3, .1, .3];
secondHand = {Red, EdgeForm[Black], makeHand[7, 7/3, .1/2, .3/2]};
clockFace = Import["http://i.imgur.com/ufanv.jpg"];
Graphics3D[{
{Texture[clockFace],
Polygon[{{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}},
VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]},
Rotate[hourHand, Dynamic[Refresh[-30 Mod[AbsoluteTime[]/3600, 60] \[Degree],
UpdateInterval -> 60]], {0, 0, 1}],
Rotate[minuteHand, Dynamic[Refresh[-6 Mod[AbsoluteTime[]/60, 60] \[Degree],
UpdateInterval -> 1]], {0, 0, 1}],
Rotate[secondHand, Dynamic[Refresh[-6 Mod[AbsoluteTime[], 60] \[Degree],
UpdateInterval -> 1/20]], {0, 0, 1}]}, Boxed -> False]
Edit
The animation was captured by using Rasterize[] inside a scheduled task!
a = Graphics3D[(* etc etc*)];
b = {};
t = CreateScheduledTask[AppendTo[b, Rasterize#a], {2, 30}];
StartScheduledTask[t];
While[MatchQ[ScheduledTasks[], {ScheduledTaskObject[_, _, _, _,True]}],Pause[1]];
RemoveScheduledTask[ScheduledTasks[]];
Export["c:\\test.gif", b, "DisplayDurations" -> 1]
Mathematica has something called ClockGauge built-in. The possibilities for styling the clock face are endless, as can be seen in the documentation. The bare-bone version looks like this:
ClockGauge[]
Your method is fine. It is just a little messy. Here is my interpretation:
hours = 12;
radius = 1;
thetaList = Rest#Range[2 Pi, 0, -2 Pi/hours] + Pi/2;
coordinateList = radius {Cos##, Sin##} & /# thetaList;
Graphics[{
FontFamily -> "Georgia",
FontSize -> 30,
Text ~MapThread~ {Range#hours, coordinateList},
Circle[{0, 0}, 1.2 radius]
}]

Line Style using Graphics3D in Mathematica

Consider the following :
cAxes = {{{0, 0, 0}, {0, 0, 1}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0,0}, {1, 0, 0}}};
Graphics3D[{Line /# cAxes}, Boxed -> False]
How can Style differently the 3 lines ?
The answer above are good, but I want to show some alternatives.
I show that it is possible to use Style for this, and that Tube is an interesting alternative to Line.
cAxes = {{{0, 0, 0}, {0, 0, 1}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0,
0}, {1, 0, 0}}};
tubes = Tube## ~Style~ #2 & ~MapThread~ {cAxes, {Red, Green, Blue}};
Graphics3D[tubes, Boxed -> False]
Here's an example:
colors = {Red, Green, Blue};
style = {Dashed, DotDashed, Dotted};
cAxes = {{{0, 0, 0}, {0, 0, 1}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0,
0}, {1, 0, 0}}};
Graphics3D[{#1, #2, Line##3} & ### Transpose#{colors, style, cAxes},
Boxed -> False]
You could also use MapThread:
cAxes = {{{0, 0, 0}, {0, 0, 1}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0, 0}, {1, 0, 0}}};
Graphics3D[{
MapThread[{#1, Line[#2]} &, {{Red, Blue, Green}, cAxes}]
}, Boxed -> False]
Also remember that you can do the same with Plot3D if you need it:
colors = {Red, Green, Blue};
style = {Dashed, DotDashed, Dotted};
Plot3D[{}, {x, 0, 10}, {y, 0, 10},
AxesLabel -> {x, y, z},
AxesStyle -> Directive /# Transpose#{colors, style},
Boxed -> False]
Untested (I don't have access to Mathematica right now):
Graphics3D[Transpose#{{Red, Green, Blue}, Line /# cAxes}, Boxed -> False]

Gradient Fill using Graphics in Mathematica

How could I create the following using Rectangle[] in Graphics[]?
Using Polygon, you can
Graphics[{EdgeForm[Black],
Polygon[{{0, 0}, {3, 0}, {3, 1}, {0, 1}},
VertexColors -> {White, Red, Red, White}]}]
Also:
Graphics[Raster[{Range[100]/100}, ColorFunction -> (Blend[{White, Red}, #] &)],
AspectRatio -> .3,
Frame -> True,
FrameTicks -> None]

Conditional coloring based on a gradient

Please consider :
Manipulate[
Row[{
Graphics[Disk[]],
Graphics[{
Polygon[{{0, 0}, {3, 0}, {3, 1}, {0, 1}},
VertexColors -> {White, Blend[{White, Blue}],
Blend[{White, Blue}], White}],
Black, Thick,
Line[{{i, 0}, {i, 1}}]}, ImageSize -> 300]}],
{i, 0, 3}]
Using Szabolcs`s solution on Gradient Filling
How could I color the disk with the color located underneath the Black Line ?
Here is one solution which works because the color on the left is White and the gradient is linear.
With[{max = 3, color = Blend[{White, Blue}]},
Manipulate[
Row[{Graphics[{Opacity[i/max], color, Disk[]}],
Graphics[{Polygon[{{0, 0}, {max, 0}, {max, 1}, {0, 1}},
VertexColors -> {White, color, color, White}], Black, Thick,
Line[{{i, 0}, {i, 1}}]}, ImageSize -> 300]}], {i, 0, max}]]
If you had two different colors for each end (i.e., something other than White), the Opacity approach won't work. Instead, you can use the optional blending fraction argument to Blend the colors in the desired proportion. Here's an example:
With[{max = 3, color1 = Red, color2 = Green},
Manipulate[
Row[{Graphics[{Blend[{color1, color2}, i/max], Disk[]}],
Graphics[{Polygon[{{0, 0}, {max, 0}, {max, 1}, {0, 1}},
VertexColors -> {color1, color2, color2, color1}], Black,
Thick, Line[{{i, 0}, {i, 1}}]}, ImageSize -> 300]}], {i, 0,
max}]]
If you need to do this for a blend of colours other than something and white, Opacity won't be suitable. You could instead stay closer to Szabolcs' original solution using the second argument to Blend like so:
skyBlue = Blend[{White,Blue}];
Manipulate[ Row[{ Graphics[{Blend[{White,skyBlue},i/3], Disk[]}],
Graphics[{ Polygon[{{0, 0}, {3, 0}, {3, 1}, {0, 1}},
VertexColors -> {White, skyBlue,
skyBlue, White}], Black, Thick,
Line[{{i, 0}, {i, 1}}]}, ImageSize -> 300]}], {i, 0, 3}]
I have divided i by 3 because that parameter is meant to vary between 0 and 1.

Uniformly distribute Points within an object using Graphics in Mathematica

Considering :
preferred ={{1, 1, 63}, {2, 1, 44}, {3, 1, 27}, {4, 1, 33}, {5, 1, 33}}
frmWidth = 20.9067;
frmHeight = 15.68;
I am displaying 5 types of stimuli 2 by 2. Subjects must choose the one they prefer. Each type of stimuli is displayed 80 times so :
{1,1,63} indicates that the stimuli Cond 1 was preferred 63 times out of the 80 times it was displayed.
{3, 1, 27} indicates that the stimuli Cond 3 was preferred 27 times out of the 80 times it was displayed.
Cond1 refers to center of the screen
Cond2 refers to Top-Left Quadrant
Cond3 refers to Top-Right Quadrant
Cond4 refers to Bottom-Left Quadrant
Cond5 refers to Bottom-Right Quadrant
I would like to express this showing results.
This is what I have done :
Graphics[{
Black, EdgeForm[{Thin, LightGray}],
Rectangle[{-1, -1}, {frmWidth + 1, frmHeight + 1}],
PointSize[0.03],
Yellow,
Point#Tuples[{Range[0, frmWidth/2, frmWidth/19],
Range[0, frmHeight/2, frmHeight/14]}][[;; preferred[[5, 3]]]],
Red,
Point#Tuples[{Range[frmWidth/2, frmWidth, frmWidth/19],
Range[0, frmHeight/2, frmHeight/14]}][[;; preferred[[4, 3]]]],
Green,
Point#Tuples[{Range[frmWidth/2, frmWidth, frmWidth/19],
Range[frmHeight/2, frmHeight, frmHeight/14]}][[;; preferred[[3, 3]]]],
Orange,
Point#Tuples[{Range[0, frmWidth/2, frmWidth/19],
Range[frmHeight/2, frmHeight, frmHeight/14]}][[;;
preferred[[2, 3]]]],
Blue,
Point#Tuples[{Range[frmWidth/4, 3/4 frmWidth, frmWidth/19],
Range[frmHeight/4, 3/4 frmHeight, frmHeight/14]}][[;;
preferred[[1, 3]]]]
}]
Problem is the rectangles are gradually filled with points from left to right, instead of the points being uniformly located.
Consider the following :
Graphics[{
White, EdgeForm[Thick],
Rectangle[{0, 0}, {frmWidth, frmHeight}],
Orange, Opacity[.5],
Rectangle[{0, frmHeight/2}, {frmWidth/2, frmHeight}, RoundingRadius -> 3],
Green,
Rectangle[{frmWidth/2, frmHeight/2}, {frmWidth, frmHeight},RoundingRadius -> 3],
Red,
Rectangle[{frmWidth/2, 0}, {frmWidth, frmHeight/2}, RoundingRadius -> 3],
Yellow,
Rectangle[{0, 0}, {frmWidth/2, frmHeight/2}, RoundingRadius -> 3],
Blue,
Rectangle[{frmWidth/4, frmHeight/4}, {3/4 frmWidth, 3/4 frmHeight}, RoundingRadius -> 3]
}]
Now I would like to fill those edge rounded rectangles with the points but have the density changing rather than the part of the rectangles that are filled.
Below is something very ugly I draw in PPT :
Ideally, the shapes filled with Points could be of any kind.
Points would not overlap.
Please let me know alternative ideas.
OK, try this:
Manipulate[ld = Floor[Sqrt[n]];
Graphics[
{{EdgeForm[Dashed], White,
Polygon[{{0, 0}, {0, h}, {w, h}, {w, 0}}]},
Point[Flatten[#, 1] &#
Table[{x, y}, {x, 0, w, w/ld}, {y, 0, h, h/ld}]] },
PlotRange \[Rule] {{-1, 20}, {-1, 20}}],
{{n, 25}, 10, 100, 1},
{{h, 10}, 5, 20},
{{w, 10}, 5, 20}]
typical configuration:
(the code I gave lets you control the total number and size of the box via sliders)
Given that your rectangles are rather small, the easiest solution is to use
RandomSample[ allPointsInAnObject ]
Kind of like so:
Graphics[{Circle[{0, 0}, 11], PointSize[0.02],
Point[RandomSample[
Cases[Outer[List, Range[-11, 11], Range[-11, 11]], {x_, y_} /;
x^2 + y^2 <= 11^2, {2}], 50]]}]

Resources