Opacity in EPS figures - wolfram-mathematica

When saving graphics in Mathematica, is it possible to save figures with opacity in EPS format? For example,
Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10},
Filling -> Axis]
gives the following figure which saves neatly in any format other than EPS.
If I try saving to EPS (in Mathematica 7), the result looks like
In Mathematica 8 it looks like
Does anyone know how to get opacity in EPS plots (or if that is even possible)? The 'use rasterization for transparency' option doesn't look as impressive as a true EPS on zooming.

I usually Rasterize my graphics in this situation. Try
Rasterize[Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]],
{x, 0, 10}, Filling -> Axis], RasterSize -> 600, ImageSize -> 400]
Of course, the result will not be scalable and can take up more memory. You can partially solve the scalability problem by setting the RasterSize larger than the ImageSize, as I have done here.

OK, so EPS can not support true transparency/opacity - but that doesn't mean that Mathematica 7 is excused for doing such a bad job. As evidenced my Mathematica 8, it is possible to make it look better.
The problem with Mathematica 7's output is that it uses the same color for the fill as for the curves, when you really want a lighter color. EPS is a plain text format, so it's quite easy to write a quick hack. Here's a quick tute on PS graphics.
In PS graphics, you define a path then you say whether you want it stroked (lines) or filled (areas) - or other things we don't need to worry about. Colors are set and stay there until they are reset. So I simply import the EPS produced by Mma7 and find all filled paths. For each filled path you find the previous color and reset the color just above the fill command to be something lighter.
So here's an example (I haven't bothered packaging it up into a single script/module).
All output is from Mathematica 7.0.1
p = Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10}, Filling -> Axis]
Export to an EPS file using Export["BesselJs7.eps", p]. This produces a horrible graphic like
OK, now the "fix"
pList = Import["BesselJs7.eps", "List"]; (* Import image as a list of strings *)
FList = Flatten#Position[pList, "F"]; (* find all fill commands *)
Note that the EPS file has the line /F { fill} bind def that defines the shortcut F.
Also, you can check that pList[[FList - 1]] yields a list of "closepath"s.
FColorList = {}; (* get list of colors associated with fills *)
Catch[Do[
i = 0; rgb = True; newpath = True;
While[rgb || newpath,
(*Print[{f,i,f-i,rgb,newpath,pList[[f-i]]}];*)
If[rgb && StringMatchQ[pList[[f - i]], __ ~~ "r"], rgb = False;
AppendTo[FColorList, pList[[f - i]]]];
If[newpath && StringMatchQ[pList[[f - i]], "newpath" ~~ __],
newpath = False; np[f] = f - i];
If[f - i == 1, Throw[{f, rgb, newpath}]];
i++],
{f, FList}]]
Now a hack to create the new colors - all I do is add .5 to each rgb value. This can definitely be made better:
FColorListNew = Table[Most#ToExpression#StringSplit[f] + .5,
{f, FColorList}] /. _?(# > 1 &) -> 1.;
FColorListNew = Table[StringJoin[{Riffle[ToString /# f, " "], " r"}],
{f, FColorListNew}];
Finally, insert the new colors and write it back out:
Do[pList = Insert[pList, FColorListNew[[i]], np[FList[[i]]] + i],
{i, Length[FList]}]
Export["BesselJsFixed.eps", pList, "List"]
Some things, like finding the newpath locations, are unnecessary and the whole thing can probably be tidied up. But I've spent enough time on it for now!

Building on Mark's answer, to export a PNG with transparency, use:
Export[
"testfile.png",
Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10}, Filling -> Axis],
ImageSize -> 600,
Background -> None
]

Related

Parametrizing 3D geometry for shape optimization

I am trying to parametrize a 3D geometry for shape optimization. The structure looks like the following. Another real example is here.
Currently I am using BSplines to create the lower part and using symmetry to create the whole down part of the foil. Here is what I get.
Now I have many control points to take care in order to run a shape optimization. I also don't know how to join the upper part with the bottom hydrofoil part in a sensible way. I don't know how to design a good middle part of the foil (fat nose part of the foil) where the upper part is linked to. I also need to accompany a flap with in the geometry.
Please offer some suggestion for parametrization of such a surface so that we can manipulate the geometry from MMA. The less control points are there better the situation is for optimization. May be combination of some analytic function in 3D. But I doubt if that is possible.
BR
I think you have two choices: 1) create the second part of the geometry and then write a face-face intersection algorithm to merge them. 2) create the second part of the geometry and write two functions that return -1 if a query point is inside the geometry and +1 if it is out side (other values will do). Then use RegionPlot3D[ f1[x,y,z]<0 || f2[x,y,z]<0,....]. The idea is the to extract the GraphicsComplex and use that. The question is going to be how well you can approximate the corners with that. Here is an illustration of what I mean.
if1[x_, y_, z_] := If[x^2 + y^2 + z^2 <= 1, -1, 1]
if2[x_, y_, z_] := If[(x - 1)^2 + y^2 <= 1 && -1.5 <= z <= 1.5, -1, 1]
res = RegionPlot3D[
if1[x, y, z] < 0 || if2[x, y, z] < 0, {x, -2, 2}, {y, -2,
2}, {z, -2, 2}, PlotPoints -> 100, Boxed -> False, Axes -> False]
Then extract the coords and the polygons.
coords = res[[1, 1]];
poly = Cases[res[[1]], _Polygon, Infinity];
Graphics3D[GraphicsComplex[coords, poly], Boxed -> False]
Hope this helps.

How to force Plot to use the specificed ImageSize in 3D when using the mouse to rotate an image

(Mathematica version: 8.0.4, on Windows 7)
Could someone please remind me how to tell M not to change the ImageSize in the following case:
I have a Manipulate, where I make a grid, and inside the grid, I either show one plot, or 2 plots, depending on a control choice.
To keep the overall displayed image the same, then if I am displaying one plot I use one size, and if I am displaying 2 plots, I use half the length for each plot. Easy enough so far.
The strange thing is that when I use the mouse to rotate the one plot case, and then switch back to 2 plots, the plot size now does not use the ImageSize I specified.
It seems by using the mouse to rotate one plot, it affected the next plot shown on the same screen location.
Using SphericalRegion -> True or not, has no effect. Using RotationAction -> "Fit" has no effect.
Here is a small example of what I mean, and then I show how I currently solve this problem. But I solve it by using GraphicsGrid in place of Grid. I wanted to keep using Grid if possible.
Manipulate[
Module[{opt = {Spacings -> {0, 0}, Frame -> All}, p,
size, data = Table[RandomReal[], {10}, {10}], wid = 300, len = 300},
size = If[choice == 1, {wid, len}, {wid, len/2}];
Print[size];
p = ListPlot3D[data,SphericalRegion->True,ImagePadding -> 10,ImageSize ->size];
If[choice == 1,
Grid[{{p}}, Sequence#opt], Grid[{{p}, {p}}, Sequence#opt]
]
],
Row[{SetterBar[Dynamic[choice], {1, 2}]}],
{{choice, 2}, None}
]
To reproduce the problem, is simple: first I note the size, this is how I want to keep it. Now I click on choice 1, now using the mouse I rotate the one plot. Now I click on choice 2 to go back, then I see the plot size is not what I expected it to be.
I am sure it is an option I need to use. Just have not found it yet.
ps. Actually what seems to happen, is that the SAME plot that was rotated, stays on the content area, and was used in place of one of the 2 plots in the second case. Very strange. I must be doing something silly somewhere, as this is too strange.
Update 2:48 am
This is in response to using Dynamic in the Manipulate expression as shown below by MrWizard. On V 8.04, it does not work. Here is the code:
Manipulate[
Module[{p, size, data = Table[RandomReal[], {10}, {10}], wid = 300,
len = 300},
size = If[choice == 1, {wid, len}, {wid, len/2}];
p = ListPlot3D[data, SphericalRegion -> True, ImagePadding -> 10,
ImageSize -> size];
If[choice == 1,
Grid[{{p}}],
Dynamic#Grid[{{p}, {p}}]
]
],
Row[{SetterBar[Dynamic[choice], {1, 2}]}],
{{choice, 2}, None}
]
Update 3:03 am
This below works by keeping the Grid. Adding a Frame around the grid makes it works.
(Thanks to Mike answer showing that using Frame instead of Grid made it work, I figured let me try to add a Frame around the Grid)
One of the strangest things I've seen using Mathematica for long time :)
Manipulate[
Module[{p, size, data = Table[RandomReal[], {10}, {10}], wid = 300,
len = 300},
size = If[choice == 1, {wid, len}, {wid, len/2}];
p = ListPlot3D[data, SphericalRegion -> True, ImagePadding -> 10,
ImageSize -> size];
If[choice == 1,
Framed#Grid[{{p}}],
Grid[{{p}, {p}}]
]
],
Row[{SetterBar[Dynamic[choice], {1, 2}]}],
{{choice, 2}, None}
]
Thanks
This is related to another puzzle re how//why Plot3D remembers image options why does Plot3D remember.... The solution happens to be the same in this case too: that is, add PreserveImageOptions -> False as an option to Plot3D. Somehow, the hacks like the ones suggested by MrW and Mike force Plot3D to "forget".
I haven't got long but the use of Grid seems to be the main thing messing this up, though I haven't had time to identify how/why. If you replace the If statement with this:
If[choice == 1, Framed#p, Grid[{{p}, {p}}, Sequence#opt]]
then it works fine. There are some other things going on in the code that don't seem optimal at first glance but I have just focussed on the graphics sizing due to time constraints. This is not intended as an explanation but might help you or someone else figure out why this is behaving like this. Sorry but short on time but thought it was worth posting the observation about Grid.
Without doing any actual analysis, here is my conjecture.
I believe this may the result of an optimization technique which observes that the apparent content of the displayed graphic did not change. I suppose that the key is therefore to make the apparent content different between each graphic that is displayed in each position of the Grid. Using something like Identity will not work as it vanishes from the expression. However if this conjecture is correct I expect any persistent change to result in an updated graphic.
I have had success using each of these for the first Grid expression:
Grid[{{ Framed#p }}, opt]
Grid[{{ Panel#p }}, opt]
Grid[{{ Pane#p }}, opt]
Grid[{{ {p} }}, opt]
Grid[{{ Item#p }}, opt]
Grid[{{ Style#p }}, opt]

Use polyhedron as graphics primitive, placing at point and scaling

Can I ask an easy beginner's question, to which I'm unable to find an easy to understand answer in any of the texts I have (which are admittedly quite old, predating version 6 in some cases)? How do you use the polyhedra as if they were graphics primitives like Sphere and Cuboid? Ie, centred at a point and scaled. Here are silly examples to illustrate the point:
(* spheres along a path *)
data = Table[{Cos[t], Sin[t], Sin[t] Cos[2 t]}, {t, 0, 2 Pi, Pi/24}];
Graphics3D[Sphere[#, 0.3] & /# data]
(* cubes along a path *)
Graphics3D[Cuboid[#, # + 0.1] & /# data]
So how to place icosahedra at specific points and scale, writing something like
Graphics3D[icosahedron[#, 0.1] & /# data]
Edit: I think my problem is how to make GraphicsComplex and Graphics3D work together. Eg, where I currently have:
shapes[ct_, siz_] := {Sphere[ct - .2, siz ], Sphere[ct - 0.1, siz]};
Graphics3D[{{shapes[#, size] & /# data}}]
I'd like to replace that Sphere[] with icosahedron[]. Am currently trying to make Heike's solution work...
Edit 2: Working fine now, thanks Heike. Not sure I'll get it 3D-printed though - looks a bit uncomfortable to wear...
You could do something like this:
icosahedron = PolyhedronData["Icosahedron"][[1]];
Graphics3D[Translate[Scale[icosahedron, .1], #] & /# data]

Slow ListPlot with PlotMarkers

I am doing this:
ClearAll[matrix];
matrix[p_,q_,nu_:0]:=Module[{sigma},
sigma=p/q;
N#SparseArray[
{{m_,m_}\[Rule]2Cos[2\[Pi]*m*p/q+nu],{i_,j_}/;
Abs[i-j]\[Equal]1\[Rule]1},{q,q}]]
ClearAll[attachsigma]
attachsigma[sigma_,lst_]:={sigma,#}&/#lst
and then execute
fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates;
pq = {Numerator##, Denominator##} & /# fracs;
(ens = Eigenvalues[#] & /#
Normal /# (matrix[#[[1]], #[[2]]] & /# pq);) // Timing
pts = Flatten[#, 1] &#MapThread[attachsigma, {fracs, ens}];
and finally I plot the points as follows (here is the real point of the question):
plot = ListPlot[pts,
PlotMarkers \[Rule] Graphics[{PointSize[Tiny], Point[{0, 0}]}]]
Calculating all the points takes around around 2.6s on my machine, but the plot takes around 25s. If, on the other hand, I plot it like this
ListPlot[pts]
then it is almost instantaneous, as it should (it's just 5256 points). So, it seems PlotMarkers slows things down immensely.
Could anybody
a) explain why (this much I vaguely understand, in analogy with what happens to Sort if you give it custom ordering function) and, more importantly,
b) explain how to avoid this slowdown? I am trying to create plots with quite a bit more points than this so they're really slow; in addition, I am creating lots of them (a movie actually).
One solution would be to not plot all of them, but as I vary parameters it becomes nontrivial to find out which I should include and which not (this would of course work if I only needed this one frame). So, I'd like to speed up the plot creation without removing points.
EDIT: Answered after hints from Sjoerd:
ListPlot[pts] /. Point[List[x___]] \[RuleDelayed] {PointSize[Tiny], Point[List[x]]}
produces the right thing instantaneously. This simply replaces the Points inside the Graphics structure by smaller points by hand.
Now one can increase the upper limit in the table in fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates to 80 or so to get many more points (this thing is the Hofstadter butterfly, and it's a fractal):
PlotMarkers is meant for data plots that contain relatively few points. It is very useful in plots in which you use the markers to identify various conditions. Each individual marker is an Inset as follows:
Inset[Graphics[List[Hue[0.67`,0.6,0.6`],PointSize[Tiny],Point[List[0, 0]]]],10512].
You can imagine this takes up some time and memory.
I also found what seems to be a bug. The plot with PlotMarkers is structured as GraphicsComplex[pointlist,graphicsinstructions]. This point list seems to contain the points in the plot twice!
In[69]:= pts // Length
Out[69]= 5256
In[66]:= plot[[1, 1]] // Length
Out[66]= 10512
In[64]:= Union[plot[[1, 1]]] == Union[pts]
Out[64]= True
In[68]:= Tally[plot[[1, 1]]][[All, 2]] // Mean (*the average number each point occurs*)
Out[68]= 2
Personally, I prefer Graphics to ListPlot, especially when the number of points is large.
Graphics[{Hue[{2/3, 1, 1, .5}], AbsolutePointSize[1.5], Point#pts},
PlotRange -> {{0, 1}, {-4, 4}}, Axes -> False,
AspectRatio -> 1/GoldenRatio]
gives, for example:
Length#pts
102969
I believe the solution you appended to your question can be simplified:
ListPlot[pts] /. x_Point :> {PointSize[Tiny], x}
I voted for both prior answers, but I agree with TomD on the direct use of Graphics.

is mathematica able to do some planar geometry plotting

I am trying to use computer to show some planar geometry plots. I donot know what software can do this, or whether mathematica can produce such plots easily.
For example, I have the following plot to show.
Given any triangle ABC, let AD be the line bisecting angle BAC and intersecting BC at D. Let M be the midpoint of AD. Let the circle whose diameter is AB intersects CM at F.
How to produce these plots and show the relevant labeling of the points in mma? Is it easy to do? Could someone please give an example, or give some recommendation as to what software is best suited for this purposes?
Many thanks.
Here you have your graph done with Geometry Expressions in two minutes. It has many nice features, including elemental geometry calculations and an interface for exporting formulas to Mathematica.
The formula in the drawing was calculated by the program.
Free to use, $79 - $99 to be able to save.
Here's a very quick solution using GeoGebra to the problem you described.
It is the first time I've used GeoGebra and this took me about 20mins to make - so the program is quite well made and intuitive.
What's more, it can export to dynamic, java based, webpages. Here's the one for the problem you specified: TriangleCircle.
Edit
For Mathematica demonstrations, there are lots of good examples at Plane Geometry.
From this page, I found other software such as Cabri Geometry and The Geometer's Sketchpad.
I thought I'd show how one might approach this in Mathematica. While not the simplest thing to code, it does have flexibility. Also bear in mind that the author is fairly inept when it comes to graphics, so there might be easier and/or better ways to go about it.
offset[pt_, center_, eps_] := center + (1 + eps)*(pt - center);
pointfunc[{pt_List, center_List, ptname_String}, siz_,
eps_] := {PointSize[siz], Point[pt],
Inset[ptname, offset[pt, center, eps]]};
Manipulate[Module[
{plot1, plot2, plot3, siz = .02, ab = bb - aa, bc = cc - bb,
ac = cc - aa, cen = (aa + bb)/2., x, y, soln, dd, mm, ff, lens,
pts, eps = .15},
plot1 = ListLinePlot[{aa, bb, cc, aa}];
plot2 = Graphics[Circle[cen, Norm[ab]/2.]];
soln = NSolve[{Norm[ac]*({x, y} - aa).ab -
Norm[ab]*({x, y} - aa).ac ==
0, ({x, y} - cc).({-1, 1}*Reverse[bc]) == 0}, {x, y}];
dd = {x, y} /. soln[[1]];
mm = (dd + aa)/2;
soln = NSolve[{({x, y} - cen).({x, y} - cen) - ab.ab/4 ==
0, ({x, y} - cc).({-1, 1}*Reverse[mm - cc]) == 0}, {x, y}];
ff = {x, y} /. soln;
lens = Map[Norm[# - cc] &, ff];
ff = If[OrderedQ[lens], ff[[1]], ff[[2]]];
pts = {{aa, cen, "A"}, {bb, cen, "B"}, {cc, cen, "C"}, {dd, cen,
"D"}, {ff, cen, "F"}, {mm, cen, "M"}, {cen, ff, "O"}};
pts = Map[pointfunc[#, siz, eps] &, pts];
plot3 = Graphics[Join[pts, {Line[{aa, dd}], Line[{cc, mm}]}]];
Show[plot1, plot2, plot3, PlotRange -> {{-.2, 1.1}, {-.2, 1.2}},
AspectRatio -> Full, Axes -> False]],
{{aa, {0, 0}}, {0, 0}, {1, 1}, Locator},
{{bb, {.8, .7}}, {0, 0}, {1, 1}, Locator},
{{cc, {.1, 1}}, {0, 0}, {1, 1}, Locator},
TrackedSymbols :> None]
Here is a screen shot.
Daniel Lichtblau
Wolfram Research
Mathematica isn't the best software for this, although it will work out.
http://demonstrations.wolfram.com/DrawingATriangle/ has source code for a really nice triangle, and following that example you can add a bisecting line to the code.
As already stated, Mathematica is not the best software for this. There are several better options that you can use, depending on your exact purpose. To generate such figures programatically, there are several languages especially adapted for such tasks. I would recommend to try eukleides or GCLC. If you have any experience with TeX/LaTeX, you may want to look at metapost or asymptote, or even a LaTeX package such as tkz-euklide.
If you on the other hand prefer to create you drawings in an interactive way, there are number of programs available. Search the web for "dynamic geometry software", you should get a number of hits. Of those I would most recommend geogebra.
I thought that I should really attempt this problem in Mathematica (only once I finished did I see Daniel's solution). It took me about half an hour - which is longer than my GeoGebra solution, despite the fact that I'd never used GeoGebra before.
The code is not as fast as it could be. This is because I was too lazy to code up proper code for finding intersections of lines and circles, so I just used the slower but more general FindInstance.
A quite comprehensive plane geometry package can be found as part of Eric Weinstein's MathWorld packages. It includes all the intersection, bisection etc... code that you could possibly want, but it would take a little bit of time to learn it all.
angleBisector[A_,{B_,C_}]:=Module[{ba=Norm[B-A],ca=Norm[C-A],m},
m=A+((B-A)/ba+(C-A)/ca)]
intersect[Line[{A_,B_}],Line[{C_,D_}]]:=Module[{s,t},
A + s(B-A)/.First#FindInstance[A + s(B-A) == C + t(D-C), {s,t}]]
intersect[Line[{A_,B_}],Circle[p0:{x0_,y0_},r_]]:=Module[{s,x,y},
A + s(B-A)/.FindInstance[A + s(B-A) == {x,y}
&& Norm[p0-{x,y}] == r, {s,x,y}, Reals, 2]]
Manipulate[Module[{OO,circ,tri,angB,int,mid,FF},
OO=(AA+BB)/2;
circ=Circle[OO,Norm[AA-BB]/2];
tri=Line[{AA,BB,CC,AA}];
angB=angleBisector[AA,{BB,CC}];
int=intersect[Line[{BB,CC}],Line[{AA,angB}]];
mid=(AA+int)/2;
FF=intersect[Line[{CC,mid}],Circle[OO,Norm[AA-BB]/2]];
Graphics[{PointSize[Large],Point[{OO,int,mid}],Point[FF],tri,circ,
Line[{AA,AA+3(angB-AA)}],Line[{CC,CC+3(mid-CC)}],
Text["A",AA,{2,-2}],Text["B",BB,{-2,-2}],Text["C",CC,{2,2}],
Text["O",OO,{0,-2}],Text["D",int,{-2,-1}],Text["M",mid,{-2,-1}]},
PlotRange->{{-2,2},{-2,2}}]],
{{AA,{-1,1}},Locator},
{{BB,{1,1}},Locator},
{{CC,{0,-1}},Locator}]

Resources