Extracting a function from a Contour Plot

What you may not know is that the notebook interface is a bit like a web browser. Whatever complicated interface the web browser is showing, you can always just right-click and show the HTML source code for it. It's not delivered as a bunch of pixels, and similarly, graphics (to be distinguished from actual images, including rasterized graphics) are just expressions. Consequently, you don't need to use a third-part tool to get the coordinates of the line. Just do it like this:

sol = ParametricNDSolve[{y'[t] == a y[t], y[0] == 1}, y, {t, 0, 10}, {a}];
cp = ContourPlot[y[a][x] /. sol, {x, 0, 0.1}, {a, 0, 4}, Contours -> {1.15}];
line = First@Cases[Normal[cp], _Line, Infinity];

Visualizing it to make sure it's working:

Graphics[{line}, PlotRange -> {{0, 0.1}, {0, 4}}, AspectRatio -> 1]

Output

It seems like you already have a way forward from this point with polynomial fitting that you have done previously.

Normal is needed because in the expression generated by ContourPlot, the line coordinates are encoded with GraphicsComplex. I use Normal to replace the coordinate indices with the actual coordinates.

I might also add that the functionality offered by the third-party tool you mention seems to be similar to a function already built into Mathematica. You can right-click the graphics in Mathematica and click "get coordinates". You can then left-click on a couple of points along the line and press ctrl+c to copy the points to clipboard. Now you can paste that data into another cell.


For this specific case the exact solution can be found.

Clear["Global`*"]

eqns = {y'[t] == a y[t], y[0] == 1};

sol = DSolve[eqns, y, t][[1]]

(* {y -> Function[{t}, E^(a t)]} *)

Verifying the solution,

eqns /. sol

(* {True, True} *)

a[x_, const_] = a /. Solve[(y[x] /. sol) == const, a][[1]] /. C[1] -> 0

(* Log[const]/x *)

With[{const = 1.15},
 Plot[a[x, const], {x, 0, 0.1},
  PlotRange -> {0, 4},
  AspectRatio -> 1,
  PlotStyle -> Directive[Thick, Red],
  Frame -> True,
  FrameLabel -> (Style[#, 14] & /@ {x, a})]]

enter image description here


My method is uglier than just extracting a spline like with C. E's answer. It's possible find points on this contour with an NMinimize and use an Interpolation to get the curve as a function of $x$ (see func below):

sol = ParametricNDSolve[{y'[t] == a y[t], y[0] == 1}, 
   y, {t, 0, 10}, {a}];
fn = y /. sol;

(* Set the target contour *)
target = 1.15;

(* For each value of 'a' find 'x' that minimizes square error of fn[a][x] to target *)
minpoints = Table[
  {x /. Last[NMinimize[{(fn[a][x] - target)^2, 0 < x < 0.1}, x]], a}, {a, 0, 4, .1}
];

(* Choose the best {x,a} solution points closest (within 10^-6) to the target value *)
filteredMinpoints = Select[minpoints, Abs[fn[#[[2]]][#[[1]]] - target] < 10^-6 &];

(* Interpolate this curve - this is now a function of 'x' we can use later *)
func = Interpolation[filteredMinpoints];
Show[
 ContourPlot[y[a][x] /. sol, {x, 0, 0.1}, {a, 0, 4}, 
  PlotLegends -> 
   BarLegend[Automatic, LegendMarkerSize -> 180, 
    LegendFunction -> "Frame", LegendMargins -> 5, 
    LegendLabel -> "y[a][x]"], Frame -> True, 
  FrameLabel -> {{"a", ""}, {"x", ""}}, 
  BaseStyle -> {FontWeight -> "Bold", FontSize -> 14}],

 (* Show a plot of the curve we interpolated *)
 Plot[Quiet@func[x], {x, 0, .1}, PlotStyle -> {Red, Thick}]
]

contour curve