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 Graphics3D object. I want to export it as a bitmap, and to calculate the bitmap-pixel coordinates of certain 3D points.
Mathematica obviously does a projection from 3D objects to 2D pixel coordinates when it draws the 3D graphic. How can I find out what this projection is?
I'd rather avoid doing lots of tricky geometrical calculations based on ViewVector and ViewAngle and ImageSize and BoundingBox. Is there a shortcut?
Damon.
You could GeometricTransform using the option "Transformation" -> "Perspective". Suppose your projected chess board looks something like this
img = Image#
Plot3D[0, {x, -1, 1}, {y, -1, 1}, Mesh -> 7,
MeshShading -> {{Black, White}, {White, Black}}, Boxed -> False,
AxesEdge -> {{-1, -1}, {-1, -1}, None}, AxesOrigin -> {-1, -1, 0}]
To find the projection you will need the coordinates of at least 4 control points in img for which you know the {x,y}-coordinates. There probably are methods to have Mathematica find these coordinates automatically but you can select them manually by right-clicking on img and choosing "Get Coordinates". Click on the control points of your choice (in this case I chose the 4 corners of the chessboard) and
copy/paste their coordinates to a new line. You should get something like
controls = {{13.5`, 151.5`}, {235.5`, 68.5`},
{332.5`, 206.5`}, {139.5`, 262.5`}};
The projection function and matrix then become
transform = FindGeometricTransform[controls,
{{0, 0}, {8, 0}, {8, 8}, {0, 8}},
"Transformation" -> "Perspective"][[2]]
transfMat = TranformationMatrix[transform]
Note that I chose the chessboard to be an 8x8 square centred at {4,4}, but you can choose any square.
A point {x,y} on the chessboard will now correspond to the point in img with pixel coordinates transform[{x,y}] or, using the projection matrix, (transfMat[[{1,2}]].{x,y,1})/(transfMat[[3]].{x,y,1}). So for example, to put a marker on D6, which would be at position {x,y}={4-1/2,6-1/2} in my 8x8 square, you could do something like
ImageCompose[img, Image[BoxMatrix[2]], Round[transform[{4 - 1/2, 6 - 1/2}]]]
When you render your Graphics3D object, you can specify the ViewMatrix option. You can set the transformation (such as a rotation) and then the projection.
This way you can use your explicit knowledge of the projection used to calculate the correct planar coordinates.
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}]] &)]
I have data in the form { {x,y,z,f}...} I am using ListContourPlot3D but all I get is an empty box with dimensions -1 to 1 in each direction. Here is my code:
ListContourPlot3D[data5, PlotRange -> All,
AxesLabel -> {"[Beta]", "[Omega]", "Vo"}, Contours -> {1500}].
These are the first 5 points of my data:( the whole set has 55 points)
{{200, 20000 10^(1/3), 2000, 1226},
{200, 20000 10^(1/3), 2600, 1422},
{200, 20000 10^(1/3), 3200, 1581},
{200, 20000 10^(1/3), 3800, 1761},
{200, 20000 10^(1/3), 4400, 1872}}
Dimensions[data5] returns {55,4}
If I do IntegerPart[data5] it does it correctly so it must recognize the numbers in my data.
I appreciate any ideas.
Thank you.
It's hard to tell without having the entire dataset, but I am betting there is a problem with your Contours -> {1500} setting. What happens if you omit it altogether or use a different value?
Contours -> num
Plots num equally spaced levels contours.
Contours -> {num}
Plots the f[x,y,z] = num contour.
Did you mean the former? I doubt ListContourPlot3D can plot your data if it is too sparse or to localized. For the data sample you gave us x and y do not vary at all. Does x and y vary enough in you final data set to well populate coordinate space?
#Davorak's suggestion that the data set, as written, does not seem to vary may be the cause of the problem. Assuming that is not the case, try rotating the resulting graphic, and if you see a black plane appear, then it is the color scheme that is off. By default, ListContourPlot3D produces an opaque white surface, and I've had issues where it did not seem to produce anything, but it was just invisible. The solution: add a ContourStyle option, and set it to something like Red.
The problem is using the {x,y,z,f} form of ListContourPlot3D at low resolution.
I stumbled over this a few weeks ago as well, here is a minimal example of the bug:
xyzfdata[r_] := Flatten[#, 2] &#Table[{x, y, z, x^2 + y^2 + z^2 - 1},
{x, -2, 2, r}, {y, -2, 2, r}, {z, -2, 2, r}];
(* Low resolution {x,y,z,f} fails *)
ListContourPlot3D[xyzfdata[1], Contours -> {0}]
The solution in my case (I had my data on a grid) was to use the grid form and DataRange:
fdata[r_] := Table[x^2 + y^2 + z^2 - 1,
{z, -2, 2, r}, {y, -2, 2, r}, {x, -2, 2, r}];
(* Low resolution works ok for array data *)
ListContourPlot3D[fdata[1], Contours -> {0},
DataRange -> 2 {{-1, 1}, {-1, 1}, {-1, 1}}]
I think the issue is that for the {x,y,z,f} form, the implementation uses interpolation in a way that fails at low resolution. Upping the resolution in the first example, everything works:
(* Higher resolution {x,y,z,f} works *)
ListContourPlot3D[xyzfdata[.2], Contours -> {0}]