Sphere Styling and Grid Spacing in Graphics3D - wolfram-mathematica

Please consider :
colors = {Red, Green, Blue};
style = {Thickness[.01], Thickness[.01], Thickness[.01]};
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},
Blue, Specularity[White, 3], Sphere[{.5, .5, .5}, .1]},
Boxed -> False, FaceGrids -> All,
FaceGridsStyle -> Directive[Black, Dashed]]
Using Yoda`s solution on How to Style Lines
How could I color the Sphere using GrayLevel (I will manipulate it later).
And How could I have denser FaceGrids ? 10 Lines horizontally & Vertically. I also don`t understand why the Edges one are distant to one another.

It's always good practice to group the graphics object and its styles in a list, in case you need to quickly add another one with different styles. By that, I mean write it as {Blue, Specularity[White, 3], Sphere[{.5, .5, .5}, .1]}. Now you can easily add a GrayLevel term before Sphere and it'll work.
For the FaceGrids, I believe you'll have to manually define the lines at your desired spacing for each face. Here's an example for showing how to do it for one face.
Graphics3D[{{#1, #2, Line##3} & ###
Transpose#{colors, style, cAxes}, {Blue, GrayLevel[0.3], Lighting -> "Neutral",
Specularity[White, 3], Sphere[{.5, .5, .5}, .1]}}, Boxed -> False,
FaceGrids -> {{{0, 0, 1},
Transpose#({#, #} & /# Range[0, 1, 0.1])}},
FaceGridsStyle -> Directive[Black, Dashed]]
The faces are defined as ±1 for the corresponding plane and the other two are zero. So {0,0,1} in my example corresponds to the z=1 plane.
The list supplied to FaceGrids can be easily computed for each face, instead of manually entering them, but I'll leave that to you :)
EDIT:
Since you want a uniform mesh all around, define where you want the grid lines drawn as
gridList = Transpose#({#, #} & /# Range[0, 1, 0.1]);
Then, use the following for FaceGrids:
FaceGrids -> Join ## Table[{RotateLeft[j {0, 0, 1}, i], gridList},
{i, {0, 1, 2}}, {j, {-1, 1}}]
Here's how the result should look like with PlotRangePadding -> None:

In addition to Yoda's response:
Lighting -> "Neutral" will allow grayscale object to show up as gray instead of with various colors.
PlotRangePadding -> None will remove the spaces on the grid lines (depending on the setting for PlotRange.)

Yoda beat me to typing out the FaceGrids setting (see documentation). But here is an alternative.
Instead of setting the FaceGrids setting explicitly, youcould also try setting FrameTicks, since by default the FaceGrids follow these, and then style the FrameTicks to be invisible using Opacity.

Related

Effect of change in Viewpoint->{x,y,z} on the size of graphic objects is not what I expected. How to fix?

If you run the following code snippet:
Manipulate[
Graphics3D[
{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0,0,0}
],
{a, 1, 100}
]
and move the viewpoint from (1,1,1) to (1,1,100) with the slider you will see that after a while the objects remain fixed in size.
Questions.
1. When I move the viewpoint further away from the scene I want the objects to become smaller. How should this be done in Mathematica?
( EDIT: )
2. What is the position of the 'camera' in relation to Viewpoint?
See ViewAngle. Under "More Information", note that the default setting ViewAngle -> Automatic is effectively equivalent to ViewAngle -> All when you zoom far enough out.
You just need to add an explicit setting for ViewAngle:
Manipulate[
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0, 0, 0},
ViewAngle -> 35 Degree], {a, 1, 100}]
As far as I know, the camera viewpoint really coincides with the position given by ViewPoint. Because Mathematica scales the result to fit in about the same image you don't see much changes but they are there. The perspective changes considerably. Try, for instance, to move away from a semi-transparant square and you'll see that the farther you go, the more the projection becomes an orthogonal projection:
If you want to scale your image according to distance you can use ImageSize. SphericalRegion is good to stabilize the image.
Manipulate[
vp = {1, 1, a};
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> vp,
AxesOrigin -> {0, 0, 0},
SphericalRegion -> True,
ImageSize -> 500/Norm[vp]],
{a, 1, 100}
]
[animation made with some ImagePadding to keep object in the center. I stopped the animation at a = 10, the image gets pretty small after that]

Mathematica: is it possible to put AxesLabel for 3D graphics at the end of the axes as in 2D?

According to
http://reference.wolfram.com/mathematica/ref/AxesLabel.html
it says
"By default, axes labels in two-dimensional graphics are placed at the ends of the axes. In three-dimensional graphics, they are aligned with the middles of the axes."
I wanted to put the axes labels at the end of the axes also for my 3D plots, since that makes it easy for me to see which axes is now where when I do rotations and such on the 3D objects.
I was not able to find a trick to do it. Here is an example
g=Graphics3D[
{
Cuboid[{-.1,-.1,-.1},{.1,.1,.1}],
{Red,PointSize[.03],Point[{3,0,0}]},
{Black,PointSize[.03],Point[{0,3,0}]},
{Blue,PointSize[.03],Point[{0,0,3}]}
},
AxesOrigin->{0,0,0},
PlotRange->{{-3,3},{-3,3},{-3,3}},
Axes->True,
AxesLabel->{"X","Y","Z"},
LabelStyle->Directive[Bold,Red,16],
PreserveImageOptions->False,
Ticks->None,
Boxed->False
]
Also, it says that the axes labels for 3D are supposed to be in the 'middle' of the axes.
But looking at the resulting Graphics3D, it does not look to me the labels are in the middle at all. Might be a scaling thing, not sure now, but it looks like the labels are too close to the origin.
thanks,
You could draw the labels manually, at the location of your choosing:
Graphics3D[
{ Cuboid[{-.1,-.1,-.1},{.1,.1,.1}]
, Text[Style["X", Bold, Red, 16], {3, 0, 0}]
, Text[Style["Y", Bold, Black, 16], {0, 3, 0}]
, Text[Style["Z", Bold, Blue, 16], {0, 0, 3}]
}
, AxesOrigin -> {0, 0, 0}
, PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}
, Axes -> True
, PreserveImageOptions -> False
, Ticks -> None
, Boxed -> False
]

Dynamic (or forced) scaling of ColorFunction

Reading this question on importing ColorData from matlab, I was wondering if there is a way to change the range of values over which the ColorFunction is scaled. That was probably not entirely clear, so let me show with a figure from matlab (the same example as in the previous question is used)
The plot on the left is the original, with the ColorData mapped to the data values between -1 and 1. Now, I can easily set it to be mapped to the data values between 0 and 1, the result being that all values less than 0 are assigned blue color (lowest in the colormap). PlotRange is the closest function, and using ClippingStyle in addition to that produces a similar figure. However, it doesn't re-scale the ColorData to map to the plot range.
How can I do this in Mathematica?
BTW, to insert colorbars using Mathematica, you can look at this function
Here's a function applied to a surface:
Plot3D[x + y, {x, -2, 2}, {y, -2, 2},
ColorFunction -> (ColorData["Rainbow", #3] &), Mesh -> {{1}, {1}}]
To look at the top-right corner, with the same color function and scaling, I set ColorFunctionScaling -> False, and manually scale the color function to map the (global) minimum to zero and the maximum to one using Rescale:
Plot3D[x + y, {x, 1, 2}, {y, 1, 2}, ColorFunctionScaling -> False,
ColorFunction -> (ColorData["Rainbow", Rescale[#3, {-4, 4}, {0, 1}]] &)]

Getting coordinates of manually drawn points

I have a graph as a result of executing ListPlot[] function.
I can manually edit this graph by moving points to a different location
and also adding new points using the Drawing Tools.
How do I get the coordinates of new and changed points from the edited graphics?
I'm not sure if the following is anything like what you want,but nevertheless:
If I use ListPlot as follows:
lp1 = Labeled[
ListPlot[Diagonal#Table[{x, y}, {x, 0, 5}, {y, 5}],
PlotStyle -> {Directive[Red, PointSize[Large]]}], "lp1"];
By double clicking on one of the red points twice to get the selection to the level of the points, I can then move the individual points, e.g., to make the points lie on a curve (rather than a straight line). I now want to extract these points (and say use them in a new ListPlot) [see plots below]
If I click on the bracket of the plot graphic and use "Show Expression" (Command Shift E on a Mac), I can 'see' the coordinates of the modified points which may then be extracted. For example:
expr = Cell[
BoxData[GraphicsBox[{RGBColor[1, 0, 0], PointSize[Large],
PointBox[{{0., 1.}, {0.8254488458250212,
2.886651181634783}, {1.9301795383300084`,
3.925201233010209}, {3.046546974446661,
4.597525796319094}, {4., 5.}}]},
AspectRatio -> NCache[GoldenRatio^(-1), 0.6180339887498948],
Axes -> True, PlotRange -> Automatic,
PlotRangeClipping -> True]], "Input",
CellChangeTimes -> {{3.504427833788156*^9, 3.50442786823486*^9}}];
Modifying a very useful approach originally suggested by Yaroslav Bulatov, which may be found here
modpoints = Flatten[Cases[expr, PointBox[___], Infinity][[All, 1]], {{2, 1}}]
EDIT
As pointed out by belisarius, it is desirable to be able to extract 'manually' added points (which may be added to the generated plot using 'point' from the Drawing Tools palette). A better way of extracting (after 'Show Expression' ...) is probably the following:
modpoints = Cases[Cases[expr, PointBox[___],
Infinity], {_?NumericQ, _?NumericQ}, Infinity]
Of course, 'Show Expression' is not the only approach.
InputForm is another possibility. For example,
expr2 = InputForm[ListPlotGraphic]
modpoints = Cases[Cases[expr, Point[___],
Infinity], {_?NumericQ, _?NumericQ}, Infinity]
where "ListPlotGraphic" is the modified graphic (inserted by 'copy and paste'), will also work.
Example plots
Addendum
The above can be automated with a little notebook programming:
lp1 = Labeled[
ListPlot[Diagonal#Table[{x, y}, {x, 0, 5}, {y, 5}],
PlotStyle -> {Directive[Red, PointSize[Large]]}],
Button["Print points",
With[{nb = ButtonNotebook[]},
SelectionMove[nb, All, CellContents];
Print[Cases[NotebookRead[nb],
PointBox[{{_?NumericQ, _?NumericQ} ..}] |
PointBox[{_?NumericQ, _?NumericQ}], Infinity]]]]]
Running the above, moving the last two original (red) points and adding a couple of extra points in blue with the drawing tools then pressing the button yields
You can see that there is a single PointBox for the original data and a new PointBox for each of the added points. Of course, by modifying the above code, you can do more than simply print out the raw point coordinates.
This approach makes every data point a locator that can be moved. New locators can be added and old ones deleted as appropriate. The best fit and variance are updated after every change.
Here's some data of some exponential growth with some errors and a data point missing
data = Delete[Table[{t, (1 + RandomReal[{-.2, .2}])Exp[t]}, {t, 0, 2, .2}], 6];
A little formatting command:
nForm = NumberForm[#, {2, 2}, NumberPadding -> {"", "0"}] &;
Finally, here's the code to make the manipulable graphics. New locators/data points are added using Alt-Click (or Ctrl-Alt-Click on linux). If you click on the list of points on the left, then a new window is opened containing the points in input form.
Manipulate[
LocatorPane[Dynamic[pts, {None, Temporary, Automatic}],
nlm = Block[{a,b,t}, NonlinearModelFit[Sort[pts], a Exp[t] + b, {a, b}, t]];
Show[Plot[{Exp[t], nlm[t]}, {t, 0, 2},
PlotStyle -> {{Thick, LightGray}, Dotted}, PlotRangePadding -> Scaled[0.1]],
ListPlot[data, PlotStyle -> Blue], AxesLabel -> Block[{t,f}, {t, f[t]}]],
LocatorAutoCreate -> True, Appearance -> Style["\[CircleDot]", Red]],
{nlm, None}, {{pts, data}, None},
Dynamic[Pane[EventHandler[
nForm#Grid[Prepend[pts, {"x", "y"}], Dividers -> {False, 2 -> True}],
{"MouseClicked" :> (CreateDocument[{ExpressionCell[nlm["Data"], "Output"]},
WindowTitle -> "Data"])}], ImageSize -> {100, 250},
ImageSizeAction -> "Scrollable", Scrollbars -> {False, True}]],
Pane[Dynamic[nForm#Row#{nlm,Row[{"\tvariance = ",nlm["EstimatedVariance"]}]}]],
ControlPlacement -> {Left, Left, Left, Top}]
In the above I've used the locators to correct a couple of outliers and restored the missing data point.
The easy option is to use the "Get Coordinates" menu option. If you right click on the graphic, in the pop-up menu you'll see "Get Coordinates" which allows you to mouse-over a point and see that point's coordinates. Of course this isn't going to be accurate... but the way you're editing the graphic isn't very accurate either.
You could use the InputForm (or FullForm) function, but I am not sure how well this works...
In[1]:= a = ListPlot[{{1, 0}, {0, 1}, {1, 1}}];
a // InputForm
Out[2]//InputForm=
Graphics[{{{}, {Hue[0.67, 0.6, 0.6], Point[{{1., 0.}, {0., 1.}, {1., 1.}}]},
{}}}, {AspectRatio -> GoldenRatio^(-1), Axes -> True, AxesOrigin -> {0, 0},
PlotRange -> {{0., 1.}, {0., 1.}}, PlotRangeClipping -> True,
PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]
You'll notice that there's a Point expression in there.
The third option would be to use Locator in some way I guess.

Getting VertexRenderingFunction to (not) scale

I'm having problem with custom VertexRenderingFunction showing at different sizes for different graphs. An example is below, the default vertex rendering function has the desired behavior since vertices look the same in all graphs, any suggestion how to achieve that with custom vertices?
(source: yaroslavvb.com)
edges = Most[
ArrayRules[GraphData[{"Path", 5}, "AdjacencyMatrix"]]][[All, 1]];
doit[vrf_] :=
Print /# Table[
GraphPlot[Rule ### edges[[k ;;]], VertexRenderingFunction -> vrf,
VertexLabeling -> True], {k, 1, Length[edges]}];
doit[({White, EdgeForm[Black], Disk[#, .1], Black, Text[#2, #1]} &)];
doit[Automatic];
Update, 1 hour later:
Michael Pilat as usual gives the solution, here's what it looks like with (Inset[Graphics[{White, EdgeForm[Black], Disk[{0, 0}, .05], Black,
Text[#2, {0, 0}]}, ImageSize -> 25], #] &) for rendering function
(source: yaroslavvb.com)
Inset a Graphics expression with the ImageSize option to place your vertices:
GraphPlot[Rule ### edges,
VertexRenderingFunction -> (Inset[
Graphics[{White, EdgeForm[Black], Disk[{0, 0}, .05], Black,
Text[#2, {0, 0}]}, ImageSize -> 25], #] &),
VertexLabeling -> True]
ImageSize can take a variety of values from printer's points to a Scaled value.
Inset can also/instead take a size in its fourth argument, but the default setting defers to the ImageSize of the inset Graphics object, which is a little cleaner to use in this case.
Hope that helps!

Resources