Related
GIven a 2D plot in Mathematica, if you keep clicking the graph, a sequence of co-ordinates of that graph are shown. I'd like to extract the x and y co-ordinates of ALL of these points, WITHOUT using the "Get Coordinates" tool (which only extracts one co-ordinate at a time, which is both inaccurate and laborious). An additional constraint is that the equation of the plot is UNKNOWN (I found a graph produced by Wolfram Alpha, the equation of which is unknown to me. If I can simply extract the co-ordinates, I can fit a spline through those co-ordinates, thereby getting the equation of the graph). Any ideas?
Cheers!
This is how it can be done in Mathematica 9.
First obtain the chart.
chart = WolframAlpha["density vs altitude of heterosphere",
{{"EntrainedDensityPlot:AtmosphericLayers", 1}, "Content"}]
Extract the data section. The x-axis is scaled according to the tick specification.
data = chart[[1, 1, 1, 1, 1, 1, 3, 2, 1]];
ListLinePlot[data, PlotRange -> All]
This is the content of the tick specification :-
ticksposition = Position[chart, Ticks];
ticks = Last#chart[[Sequence ## Most[First#ticksposition]]];
Take[First#ticks, 5][[All, 1]]
{-25.328436022934504, -18.420680743952367, -11.512925464970229`,
-4.605170185988091, 2.302585092994046}
The numbers above relate to the following tick labels :-
{10^-11, 10^-8, 10^-5, 0.01, 10};
The line data is show below. The x values can be rescaled according to the ticks.
data
{{7.56584506772668,-5.},{7.522454313212941,-4.5},{7.4785653196771396,-4.},{7.4342573821331355,-3.5},{7.38950218524746,-3.},{7.344266755495627,-2.5},{7.2985804103507865,-2.},{7.25233739856673,-1.5},{7.205635176410364,-1.},{7.158436173289435,-0.5},{7.110696122978827,0.},{7.062448668658617,0.5},{7.0136456542395695,1.},{6.964230125910116,1.5},{6.91433359434226,2.},{6.863751143484082,2.5},{6.812620083867098,3.},{6.760878083121377,3.5},{6.708511342992233,4.},{6.655491829094075,4.5},{6.601814187258075,5.},{6.547459502017843,5.5},{6.4924064877997925,6.},{6.436647039879506,6.5},{6.380156434630315,7.},{6.32290629486736,7.5},{6.264901893476659,8.},{6.206091938653852,8.5},{6.1464577290734805,9.},{6.086001700931971,9.5},{6.0246816979681785,10.},{5.962473333757384,10.5},{5.899349258200177,11.},{5.821358081393286,11.5},{5.7428108616236795,12.},{5.664279054878501,12.5},{5.585749407744609,13.},{5.507199708509977,13.5},{5.42873140526997,14.},{5.350245459408396,14.5},{5.2717680313145,15.},{5.114815113005919,16.},{4.957937505095806,17.},{4.801148069229532,18.},{4.6443908991413725,19.},{4.487624622133048,20.},{4.326976291408619,21.},{4.16682025054415,22.},{4.007442270191581,23.},{3.848827581930999,24.},{3.6909772521960824,25.},{3.533890923387621,26.},{3.3775192543075785,27.},{3.221911213411722,28.},{3.0670291554360247,29.},{2.9128939952449864,30.},{2.7595034826911258,31.},{2.606755482950629,32.},{2.4486747988659405,33.},{2.2912612192626023,34.},{2.1357509841344284,35.},{1.9820905307957144,36.},{1.680194560884901,38.},{1.3852187828929574,40.},{1.096877451374393,42.},{0.8148779691310925,44.},{0.5389464994826453,46.},{0.27512860638016096,48.},{0.02654455522211221,50.},{-0.21614311166946532,52.},{-0.44783517527478434,54.},{-0.6842865521277486,56.},{-0.9256594818782552,58.},{-1.1722157727127442,60.},{-1.8127175638195325,65.},{-2.490977037365282,70.},{-3.220852777752422,75.},{-3.992257398138752,80.},{-4.801233732898559,85.},{-4.884341907755072,85.5},{-4.967863202252387,86.},{-5.6792850030558135,90.},{-6.576295584184468,95.},{-7.486859743501422,100.},{-9.239975177105872,110.},{-10.71451777375279,120.},{-11.71724726204385,130.},{-12.472384692245763,140.},{-13.085067592660632,150.},{-13.606060333782066,160.},{-14.062050687084879,170.},{-14.470591537717763,180.},{-14.842453559942024,190.},{-15.185537946620293,200.},{-15.50507451487766,210.},{-15.805477093216508,220.},{-16.359148622816097,240.},{-16.864221756309153,260.},{-17.331782147471895,280.},{-17.7704410644037,300.},{-18.1863994482277,320.},{-18.582846794542757,340.},{-18.964546221796557,360.},{-19.333726745661632,380.},{-19.69257556476376,400.},{-20.554367300484596,450.},{-21.37431184148772,500.},{-22.157071180737354,550.},{-22.89745771517206,600.},{-23.585866797897218,650.},{-24.206758461335397,700.},{-24.74733834618318,750.},{-25.200922702635545,800.},{-25.573825183196032,850.},{-25.880257267404012,900.},{-26.137443089588984,950.},{-26.360979711632908,1000.}}
Recycling an answer from here, this function stores up mouse point clicks in a variable pts. You will need to combine your curve in the Show function, suitably scaled. Here I just put in a sine plot.
It uses a dynamic module so the points will still be there when you save, close and reopen your notebook.
CreateDistribution[] :=
DynamicModule[{savepts = {{-1, -1}}},
Dynamic[EventHandler[
Show[Plot[Sin[x], {x, 0, 7}],
ListPlot[pts, AxesOrigin -> {0, 0},
PlotRange -> {{0, 7}, {0, 5}}]],
"MouseDown" :> (savepts =
pts = DeleteCases[
Append[pts, MousePosition["Graphics"]], {-1, -1}])],
Initialization :> (pts = savepts)]]
CreateDistribution[]
pts
{{0.371185, 0.357737}, {0.859027, 0.779375}, {1.55898,
1.01471}, {2.36498, 0.661709}, {2.95887,
0.161626}, {3.55277, -0.358067}, {4.10424, -0.799316}, {4.91024, -0.985622}, {5.6314, -0.573789}, {6.20409, -0.142345}, {6.71314,
0.367543}}
I have a image(png format) in hand. The lines that bound the ellipses (represent the nucleus) are over straight which are impractical. How could i extract the lines from the image and make them bent, and with the precondition that they still enclose the nucleus.
The following is the image:
After bending
EDIT: How can i translate the Dilation And Filter part in answer2 into Matlab language? I can't figure it out.
Ok, here is a way involving several randomization steps needed to get a "natural" non symmetrical appearance.
I am posting the actual code in Mathematica, just in case someone cares translating it to Matlab.
(* A preparatory step: get your image and clean it*)
i = Import#"http://i.stack.imgur.com/YENhB.png";
i1 = Image#Replace[ImageData[i], {0., 0., 0.} -> {1, 1, 1}, {2}];
i2 = ImageSubtract[i1, i];
i3 = Inpaint[i, i2]
(*Now reduce to a skeleton to get a somewhat random starting point.
The actual algorithm for this dilation does not matter, as far as we
get a random area slightly larger than the original elipses *)
id = Dilation[SkeletonTransform[
Dilation[SkeletonTransform#ColorNegate#Binarize#i3, 3]], 1]
(*Now the real random dilation loop*)
(*Init vars*)
p = Array[1 &, 70]; j = 1;
(*Store in w an image with a different color for each cluster, so we
can find edges between them*)
w = (w1 =
WatershedComponents[
GradientFilter[Binarize[id, .1], 1]]) /. {4 -> 0} // Colorize;
(*and loop ...*)
For[i = 1, i < 70, i++,
(*Select edges in w and dilate them with a random 3x3 kernel*)
ed = Dilation[EdgeDetect[w, 1], RandomInteger[{0, 1}, {3, 3}]];
(*The following is the core*)
p[[j++]] = w =
ImageFilter[ (* We apply a filter to the edges*)
(Switch[
Length[#1], (*Count the colors in a 3x3 neighborhood of each pixel*)
0, {{{0, 0, 0}, 0}}, (*If no colors, return bkg*)
1, #1, (*If one color, return it*)
_, {{{0, 0, 0}, 0}}])[[1, 1]] (*If more than one color, return bkg*)&#
Cases[Tally[Flatten[#1, 1]],
Except[{{0.`, 0.`, 0.`}, _}]] & (*But Don't count bkg pixels*),
w, 1,
Masking -> ed, (*apply only to edges*)
Interleaving -> True (*apply to all color chanels at once*)]
]
The result is:
Edit
For the Mathematica oriented reader, a functional code for the last loop could be easier (and shorter):
NestList[
ImageFilter[
If[Length[#1] == 1, #1[[1, 1]], {0, 0, 0}] &#
Cases[Tally[Flatten[#1, 1]], Except[{0.` {1, 1, 1}, _}]] & , #, 1,
Masking -> Dilation[EdgeDetect[#, 1], RandomInteger[{0, 1}, {3, 3}]],
Interleaving -> True ] &,
WatershedComponents#GradientFilter[Binarize[id,.1],1]/.{4-> 0}//Colorize,
5]
What you have as input is the Voronoi diagram. You can recalculate it using another distance function instead of the Euclidean one.
Here is an example in Mathematica using the Manhattan Distance (i3 is your input image without the lines):
ColorCombine[{Image[
WatershedComponents[
DistanceTransform[Binarize#i3,
DistanceFunction -> ManhattanDistance] ]], i3, i3}]
Edit
I am working with another algorithm (preliminary result). What do you think?
Here is what I came up with, it is not a direct translation of #belisarius code, but should be close enough..
%# read image (indexed image)
[I,map] = imread('http://i.stack.imgur.com/YENhB.png');
%# extract the blobs (binary image)
BW = (I==1);
%# skeletonization + dilation
BW = bwmorph(BW, 'skel', Inf);
BW = imdilate(BW, strel('square',2*1+1));
%# connected components
L = bwlabel(BW);
imshow(label2rgb(L))
%# filter 15x15 neighborhood
for i=1:13
L = nlfilter(L, [15 15], #myFilterFunc);
imshow( label2rgb(L) )
end
%# result
L(I==1) = 0; %# put blobs back
L(edge(L,'canny')) = 0; %# edges
imshow( label2rgb(L,#jet,[0 0 0]) )
myFilterFunc.m
function p = myFilterFunc(x)
if range(x(:)) == 0
p = x(1); %# if one color, return it
else
p = mode(x(x~=0)); %# else, return the most frequent color
end
end
The result:
and here is an animation of the process:
Background:
a = 0; b = 0; c = 0;
Manipulate[Graphics3D[
GeometricTransformation[
{Cuboid[{0, 0, 0}, {1, 1, 1}]},
{RotationTransform[x, {1, 1, 0}, {a, b, c}]}],
ViewPoint -> Left], {x, 0, 2 \[Pi]}]
My question concerns RotationTransform with the following signature:
RotationTransform[x, {1, 1, 0}, {a, b, c}]
The documentation says: "gives a 3D rotation around the axis w anchored at the point p", in the example above w={1,1,0} and p={a,b,c}.
To my surprise the rotation acts the same no matter what values I assign to (a,b,c). I assume that I don't understand the docs, made an error somewhere. I would have expected at least a different rotation for different values of a,b,c. Changing the vector w behaves as expected.
Please explain the purpose of p.
Consider the following example from the help:
gr={Cuboid[],AbsolutePointSize[10],Opacity[1],{Magenta,Point[{0,0,0}]},
{Green,Point[{1,1,1}]}};
p = {1,1,1};
Graphics3D[{{Opacity[.35], Blue, gr},
GeometricTransformation[{Opacity[.85], Red, gr},
RotationTransform[Pi/6, {0, 0, 1}, p]]}, Boxed -> False]
And now with :
p={1,0,0};
May be this will make it clear. It does have an effect. I show the anchor point, and the axis.
Manipulate[
Module[{w={1,0,0},p={-2,2}},
Graphics3D[
{
{Opacity->.4,GeometricTransformation[
{Cuboid[{0,0,0}]},RotationTransform[angle,w,{a,b,c}]]
},
{Blue,PointSize[0.05],Point[{a,b,c}]},
{Red,Thick,Line[{{a,b,c},{a,b,c}+w}]}
},
ImageSize->300,
ImagePadding->2,AxesOrigin->{0,0,0},
ImageMargins->2,ViewAngle->All,
Axes->True,
Ticks->None,
PlotRange->{p,p,p}
]
],
{angle,0,2 \[Pi],ImageSize->Tiny},
{{a,0,"a"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
{{b,0,"b"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
{{c,0,"c"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
ControlPlacement->Left
]
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.
If given a rotation axis normalized, such as {1/Sqrt[3],1/Sqrt[3],1/Sqrt[3]}, and a 3d plot, for example,
z[x_, y_] := Exp[-(Sqrt[x^2 + y^2]/Power[4, (3)^-1]) +
Power[4, (3)^-1]*Sqrt[1/2*(Sqrt[x^2 + y^2] + x)]];
Plot3D[2*z[x, y], {x, -5, 5}, {y, -5, 5}]
I want to create an animation for this plot about the axis {1/Sqrt[3],1/Sqrt[3],1/Sqrt[3]} (could be any other arbitary one), and then export it as an animated gif. Would anyone please help? Many thanks.
Edit
I also left out one degree of freedom in specifying the rotation. Could any one please help, if also given the coordinate of a point which the rotational axis must pass, how to do the visualization/animation?
Thanks again.
Copying what Daniel did, just prepared for exporting.
axis = {1, 1, 1};
l = {-7, 7};
s = Table[
Plot3D[2*z[x, y], {x, -5, 5}, {y, -5, 5}, PlotRange -> {l, l, l}] /.
gg : GraphicsComplex[___] :> Rotate[gg, theta, axis], {theta, 0., 2. Pi}];
Export["c:\\test.gif", s]
The following parameters are available for the gif export (as per the docs):
"AnimationRepetitions" how many times the animation is played before stopping
"Background" background color shown in transparent image regions
"BitDepth" bits used to represent each color channel in the file
"ColorMap" color reduction palette, given as a list of color values
"GlobalColorMap" default color palette for individual animation frames
"DisplayDurations" display durations of animation frames, given in seconds
"ImageCount" number of frames in an animated GIF
"ImageSize" overall image size
"RawData" array of color map indices
"Comments" user comments stored in the file
I used "DisplayDurations" in the past, and it worked.
Could do as below.
axis = {1, 1, 1};
Animate[
Plot3D[2*z[x, y], {x, -5, 5}, {y, -5, 5}] /.
gg : GraphicsComplex[___] :> Rotate[gg, theta, axis],
{theta, 0., 2.*Pi}]
Daniel Lichtblau
Wolfram Research