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}}
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}]] &)]
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