How do you obtain graphic primitives and directives from a Graphics object? Leonid Shifrin showed how to remove them in the post Mathematica: Removing graphics primitives. I tried applying something similar but I can't get what I want. Consider this example:
g1 = ListPlot3D[
{{0, -1, 0}, {0, 1, 0}, {-1, 0, 1}, {1, 0, 1}, {-1, 1, 1}},
Mesh -> {2, 2},
Boxed -> False,
Axes -> False,
ViewPoint -> {2, -2, 1},
ViewVertical -> {0, 0, 1},
MeshStyle -> RGBColor[0, 0.5, 0],
BoundaryStyle -> RGBColor[1, 0.5, 0]
];
g2 = ImportString[ExportString[g1, "PDF", Background -> None], "PDF"][[1]]
g2 is now a graphics object. If you look at the InputForm of g2 you will see that this graphics object is composed of Polygons and JoinedCurves. What I would like to do is able to iterate through all of the primitive objects of g2. If we try to iterate as follows
objs = First[g2];
Table[Head[objs[[i]]], {i, 1, Length#objs}]
we obtain
{Thickness, Polygon, Polygon, Polygon, Polygon, Style, Style, Style, Style,
Style, Style, Style, Style, Style, Style, Style, Style, Style, Style, Style,
Style, Style, Style, Style, Style, Style, Style, Style, Style, Style, Style,
Style, Style, Style, Style, Style, Style, Style, Style, Style, Style, Style,
Style, Style, Style}
What I would like to obtain instead is a list of simple primitives, I do not want them inside Styles. Here is one attempt obtaining only the lines and colors:
tmp1 = Cases[objs, (_JoinedCurve | _RGBColor), Infinity];
tmp2 = DeleteCases[objs, (_Polygon | _Thickness), Infinity];
GraphicsRow[{Graphics[tmp1], Graphics[tmp2]}]
Notice that the image on the left is drawn incorrectly. This image was generated using only JoinedCurves and RGBColors. It somehow managed to miss one color, that is why we have a black line and then the rest of lines have the other color. The other image is drawn correctly, all we did was delete all the Polygons and Thickness that appeared in there. What am I doing differently here? Shouldn't we obtain the same plots?
I read:
What I would like to obtain instead is
a list of simple primitives, I do not
want them inside Styles.
You can get it just by simple replacement:
First[ g2 /. Style[expr_, opts___] :> {opts, expr} ]
Now you write:
Here is one attempt obtaining only the
lines and colors
Knowing the internal structure of g2 it is simple to extract only Line objects with its colors. It is even simpler because all Lines are wrapped with Style:
tmp3 = Cases[g2,
Style[{lines__Line}, ___, color_RGBColor, ___] :> {color, lines},
Infinity];
Graphics[tmp3]
Related
When exporting rather complicated plots (especially ListDensityPlot) as a PDF or EPS (for publication, for example), the resulting file size can be quite large. For example:
data = Flatten[Table[{f0, f, Exp[-(f - f0)^2/25^2]}, {f0, 500, 700, 5}, {f, 300,
900}], 1];
plot=ListDensityPlot[data,PlotRange->{Automatic,Automatic,{0,1}},InterpolationOrder->0]
This example data set is on the order of the size I typically work with. When I export using Export["C:\\test.pdf", plot], it generates a PDF file 23.9MB in size. If I instead try Export["C:\\test1.pdf", Rasterize[plot]] it is far smaller, but the integrity and rescalability of the image naturally suffers.
This is complicated further if my actual figure is a combined plot, such as (Edit: f goes to 900)
plot2 = Show[plot, Plot[x, {x, 500, 900}, PlotStyle -> Thick]]
(or with some usage of Epilog) where I'd love to have the background ListDensityPlot be rasterized, but keep the other markup and plots in ``vector'' form. Or at the very least, the frame labels be non-rasterized.
Is there any way to do this?
Or, to accomplish the same goal via some other clever method?
Update
I've checked out the related question, but that's gotta be way more complicated than it needs to be (essentially exporting then importing). I've been able to utilize some of the tricks in that question to extract the plot separately from the axes:
axes = Graphics[{}, Options[plot2]]
plots = Graphics[plot2[[1]]]
But, the plots term loses the AspectRatio and PlotRange, etc. plots can be hit with a Rasterize, but it needs dimensional fixing.
And then, how to combine them together?
This is exactly the kind of problem for which I wrote the function linked here:
http://pages.uoregon.edu/noeckel/computernotes/Mathematica/listContourDensityPlot.html
It's based on the same idea as in Heike's answer -- I just added some more features so that you can safely change the aspect ratio, opacity, and combine with other plots. See my comment in Heike's answer.
To try it with your data, do something like this:
plot = Show[
listContourDensityPlot[data,
PlotRange -> {Automatic, Automatic, {0, 1}},
InterpolationOrder -> 0, Contours -> None],
Graphics[Line[{{500, 500}, {700, 700}}]]]
There are a couple of similar functions linked from the parent page, too.
If you're dealing with 2D plots, you could combine a rasterized plot with vectorized axes by using Inset. For example
plot2 = ListDensityPlot[data,
PlotRange -> {Automatic, Automatic, {0, 1}},
InterpolationOrder -> 0, Axes -> False, Frame -> False,
PlotRangePadding -> 0];
plotRange = PlotRange /. AbsoluteOptions[plot2, PlotRange];
plot = Graphics[{
Inset[Image[plot2], plotRange[[All, 1]], {Left, Bottom}, Scaled[{.96, .96}]],
Line[{{500, 500}, {700, 700}}]},
Frame -> True, AspectRatio -> 1,
PlotRange -> plotRange, PlotRangePadding -> Scaled[.02]]
Export["test.pdf", plot]
produces a .pdf of about 400 KB. The frame, tick marks, and black line are still vectorized, so they stay sharp when zooming in:
If you are exporting as PDF, EPs or WMF, then the text should remain as vectors even if you have a rasterized component to the graphics.
I think the trick is to set the number of plot points to some low number in the ListDensityPlot command and then export as PDF as normal.
How about just plotting the function rather than making a list?
plot=DensityPlot[Exp[-(f - f0)^2/25^2], {f0, 500, 700}, {f, 300, 900},
Epilog -> {Thick, Line[{{500, 500}, {700, 700}}]}, PlotPoints -> 50]
Export["test.pdf", plot]
file size 1.1MB
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.
Here is an example 3D geometry.
dat=Import["ExampleData/747.3ds.gz", ImageSize -> Medium]
Now if one wants to get a BSplineFunction for this 3D geometry what is the easiest way to do it?
I can see the parts in Mathematica using the following command.
parts = Length[(dat // First // Last)];
and here comes the 3D points after extraction.
ListPointPlot3D[Flatten[Map[((dat // First // Last)[[#]] /.
GraphicsComplex[a_, b_] -> List[a]) &, Range[parts]], 1]]
I hope there is a general method so that we can form a BSpline function from any 3D graphics complex.
I suppose the general method will be able to convert Mathematica 3D representations in continuous BSplines representation.
Now we will elaborate according to the example given by belisarius.
v={{0,0,0},{2,0,0},{2,2,0},{0,2,0},{1,1,2}};
i={{1,2,5},{2,3,5},{3,4,5},{4,1,5}};
Graphics3D[{Opacity[.5],GraphicsComplex[v,Polygon[i]]}]
We can simply form the input for the BSpline surface for this example.
dat = Table[Map[v[[#]] &, i[[j]]], {j, 1, Length[i]}];
Now let's see the surface that comes out if we consider the underlying vertices.
Show[
(* Vertices *)
ListPointPlot3D[v,PlotStyle->{{Black,PointSize[.03]}}],
(* The 3D solid *)
Graphics3D[{Opacity[.4],GraphicsComplex[v,Polygon[i]]}],
(* The BSpline surface *)
Graphics3D[{Opacity[.9],FaceForm[Red,Yellow],
BSplineSurface[dat, SplineDegree-> {1,2},SplineClosed->{True,False}]}
],
Boxed-> False,Axes-> None
]
Once this surface is formed I thought it will be possible to make a BSplineFunction in some way. But what I get is completely different from the above surface.
func = BSplineFunction[dat, SplineDegree -> {1, 2},SplineClosed -> {True, False}];
Plot3D[func[x, y], {x, 0, 1}, {y, 0, 1}, Mesh -> None,PlotRange -> All]
So am I making some conceptual mistake here?
I think your question needs further clarification.
The .3DS are mainly Polygon sets like this one:
v = {{0, 0, 0}, {2, 0, 0}, {2, 2, 0}, {0, 2, 0}, {1, 1, 2}};
i = {{1, 2, 5}, {2, 3, 5}, {3, 4, 5}, {4, 1, 5}};
Graphics3D[{Opacity[.5], GraphicsComplex[v, Polygon[i]]}]
So, it is not obvious how to get Spline surfaces to model this.
Perhaps you can elaborate a little with this example.
HTH!
Minor detail: Your spline is a bit warped and that's because of your choice of SplineDegree. For the pyramid case I'd choose {2,1} instead of {1,2}.
That will give you a cone instead of the soft-ice cone you now have. Of course, that's all rather arbitrary and beauty is in the eye of the beholder.
Now for your question why a 3D plot of the BSplineFunction doesn't give the same results as a Graphics3D of a BSplineSurface with the same control points. The problem is that you assume that the two parameters in the BSplineFunction correspond to x and y of a Cartesian coordinate system. Well, they don't. Those parameters are part of an internal parametric description of the surface, in which varying these two parameters yields a set of 3D points, so you have to use ParametricPlot3D here.
So, if you change your Plot3D into ParametricPlot3D you'll see all is fine.
I hope this answers you final question. Does this also answer your question how to convert a 3D polygon based model to a spline based model? One of the problems you face is that a spline doesn't usually go through its control points, as a kind of interpolating function.
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.
How do you plot legends for functions without using the PlotLegends package?
I, too, was disappointed by the difficulty of getting PlotLegend to work correctly. I wrote my own brief function to make my own custom figure legends:
makePlotLegend[names_, markers_, origin_, markerSize_, fontSize_, font_] :=
Join ## Table[{
Text[
Style[names[[i]], FontSize -> fontSize, font],
Offset[
{1.5*markerSize, -(i - 0.5) * Max[markerSize,fontSize] * 1.25},
Scaled[origin]
],
{-1, 0}
],
Inset[
Show[markers[[i]], ImageSize -> markerSize],
Offset[
{0.5*markerSize, -(i - 0.5) * Max[markerSize,fontSize] * 1.25},
Scaled[origin]
],
{0, 0},
Background -> Directive[Opacity[0], White]
]
},
{i, 1, Length[names]}
];
It is flexible, but not so easy to use. "names" is a list of strings to render in the legend; "markers" is a list with the same length as "names" of Graphics objects representing the plot markers or graphics to render; "origin" is a two-element list with the absolute horizontal and vertical position of the upper-left corner of the legend; "markerSize" is the number of points to scale the markers to; "fontSize" is the font size; "font" is the name of the font to use. Here is an example:
Plot[{x, x^2}, {x, 0, 2}, PlotStyle -> {Blue, Red},
Epilog -> makePlotLegend[
{x, x^2},
(Graphics[{#, Line[{{-1, 0}, {1, 0}}]}]) & /# {Blue, Red},
{0.9, 0.3},
12,
12,
"Arial"
]
]
I would also be very interested in an answer to this question.
To tell you what is wrong with PlotLegends: It is terribly unstable and in many instances doesn't work at all.
Here is an example where PlotLegends screws up completely. Output is from Mathematica 7.0:
Assume that we have measured some data points corresponding to a number of functions, and we want to show how well they compare to the ideal function, or maybe how well they match with a calculated fit. No problem! We'll just Show[] the smooth plot together with a ListPlot of the data points, right?
It could look something like this:
Show[
Plot[{Sin[x], Sinh[x]}, {x, -Pi, Pi}],
ListPlot[Join[{#, Sin[#]} & /# Range[-Pi, Pi, .5],
{#, Sinh[#]} & /# Range[-Pi, Pi, .5]]]
]
Now we'd like to put a legend on the plot, so readers will know what on earth they're looking at. Easier said than done, mister! Let's add the PlotLegend to the Plot[]:
Show[
Plot[{Sin[x], Sinh[x]}, {x, -Pi, Pi}, PlotLegend -> {Sin[x], Sinh[x]}],
ListPlot[Join[{#, Sin[#]} & /# Range[-Pi, Pi, .5],
{#, Sinh[#]} & /# Range[-Pi, Pi, .5]]]
]
This looks GREAT! Publish immediately!
For such a basic and ubiquitously needed functionality, it sure has been a lot of work to find an alternative to PlotLegend that just works. The best alternative I've found so far has been to meticulously construct a list of plotstyles, then construct the legend by hand, and finally to show it together with the plot using ShowLegend[]. (See for example here) It's possible, but a lot of work.
So if anyone knows of a workaround to make PlotLegend work, an alternative package that works better, or just a neat way to get legends that can be automated easily, I would be very grateful! It would certainly make life a little bit easier.
If you are experiencing the weird behavior described by James When you are trying to use 'Show' to combine two images, then you should play around with using the 'Overlay' function instead of 'Show'.
Alternatively, I have found that as long as both graphics have a legend then 'Show' will render the composite image correctly.
If it looks a bit silly having two legends then you can remove the one from the second graphic by using options like:
PlotLegend -> {},
LegendPosition -> {0.1, 0.1},
LegendSize -> 0.001,
LegendShadow -> None,
LegendBorder -> None
This creates an empty and invisible legend but still allows the two graphics to be composed correctly by 'Show'.