wolfram-mathematica - Mathematica：提取我不知道方程的绘图的坐标

Question

给定 Mathematica 中的 2D 图，如果您继续单击该图，则会显示该图的一系列坐标。我想提取所有这些点的 x 和 y 坐标，而不使用“获取坐标”工具（一次只提取一个坐标，这既不准确又费力）。一个额外的限制是绘图的方程是未知的（我发现了一个由 Wolfram Alpha 生成的图形，它的方程对我来说是未知的。如果我可以简单地提取坐标，我可以通过这些坐标拟合样条曲线-坐标，从而得到图形的方程）。有任何想法吗？

干杯!

Answer 1

这就是在 Mathematica 9 中的实现方式。

首先获取图表。

chart = WolframAlpha["density vs altitude of heterosphere",
  {{"EntrainedDensityPlot:AtmosphericLayers", 1}, "Content"}]

提取数据部分。x 轴根据刻度规范进行缩放。

data = chart[[1, 1, 1, 1, 1, 1, 3, 2, 1]];
ListLinePlot[data, PlotRange -> All]

这是刻度规范的内容：-

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}

上面的数字与以下刻度标签有关：-

{10^-11, 10^-8, 10^-5, 0.01, 10};

线路数据如下所示。x 值可以根据刻度重新调整。

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.216123,31116},690456.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.}}

Answer 2

从这里回收一个答案，这个函数将鼠标点击存储在一个变量pts中。您需要在Show函数中组合曲线，并进行适当缩放。在这里，我只是放入了一个正弦图。

它使用动态模块，因此当您保存、关闭和重新打开笔记本时，这些点仍然存在。

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}}