# Convert symbolic to numeric code: speed up morphing

Recently I asked a question about the morphing between two functions and got two excellent answers. The accepted answer is using the continuous optimal transport theory. This seems to be very suitable for this problem.

However, I have difficulties to convert the code from symbolic to pure numeric one. In particular, I do not know how to numerically construct inverse functions and derivatives efficiently. My intention is to apply the code of Federico to the pair of two functions such as shown below

f[x_]:=UnitBox[x+3]
g[x_]:=UnitTriangle[x-3]

I take the liberty to copy the symbolic code here:

F[x_] = Integrate[f[x], {x, -∞, x}];
G[x_] = Integrate[g[x], {x, -∞, x}];
Ginv[q_] = InverseFunction[G][q];
T[t_, x_] = (1 - t) x + t Ginv[F[x]] // Simplify;
dT[t_, x_] = D[T[t, x], x] // Simplify;
ParametricPlot[Evaluate@Table[
{T[t, x], f[x]/dT[t, x]}, {t, 0, 1, .1}],
{x, -10, 5}, PlotRange -> All, AspectRatio -> 1/2]

I am seeking a pure numeric solution that can be further applied to any pair of interpolation functions. f[x] and g[x] presented above is just a simple example that cannot be integrated symbolically and because piecewise functions are hard to invert symbolically too. I've selected them because it is known that MA is not able to integrate UnitBox and UnitTriangle symbolically.

## Edit

MichaelE2 suggested to provide interpolation functions. Below are two strongly truncated realistic data to work with

ListLinePlot[{Uncompress[dataA],Uncompress[dataB]},PlotRange->{0,10},PlotTheme->{"VibrantColor","Frame"}]

I need 5 curves in between.

Solution of Federico is very nice, however it takes 52s to compute InverseCDFon 61 point. I have at least 200 points and many function-pairs. Therefore, speed is an issue. I still have to see how the solution of Carl Woll performs.

## Context

I need 9 min to generate 1 curve by doing calculations on 24-threads. My hope is to generate intermediate curves by morphing at least an order of magnitude faster then it takes to generate the original ones.

• Why not give "two interpolation functions" as an example? Then you might avoid getting answers that focus on the peculiarities of UnitTriangle and so forth. Nov 5, 2019 at 16:49

# Numeric solution

In this example I compute the $$W_2$$ geodesic (Wasserstein distance) between two densities defined as InterpolatingFunction.

(* unnormalized density functions *)
uf = Interpolation[{{-2, .5}, {0, 2}, {.5, 1}, {1, .5}}];
ug = Interpolation[{{-1, 1}, {0, .5}, {1, 2}, {2, .5}}];

(* normalized density functions *)
f[x_] = uf[x]/NIntegrate[uf[x], {x, -2, 1}];
g[x_] = ug[x]/NIntegrate[ug[x], {x, -1, 2}];
ℱ = ProbabilityDistribution[f[x], {x, -2, 1}];
\[ScriptCapitalG] = ProbabilityDistribution[g[x], {x, -1, 2}];

Show[
Plot[f[x], {x, -2, 1}, PlotStyle -> Blue, Filling -> 0],
Plot[g[x], {x, -1, 2}, PlotStyle -> Red, Filling -> 0],
PlotRange -> {All, {0, All}}, AxesOrigin -> {0, 0}]

The points xF are a linear sampling of the domain of f. The points qF are the quantiles associated to the points xG. The points xℱ are the union of the two, in order to ensure that both densities are discretized sufficiently well.

xF = Range[-2, 1, .05];
xG = Range[-1, 2, .05];
qF = InverseCDF[ℱ, CDF[\[ScriptCapitalG], xG]];
qG = InverseCDF[\[ScriptCapitalG], CDF[ℱ, xF]];
xℱ = Union[xF, qF];
x\[ScriptCapitalG] = Union[xG, qG];

X[t] is the interpolation between the starting and final points, whereas dens[t] is the intermediate density at those points.

X[t_] := (1 - t) xℱ + t x\[ScriptCapitalG]
dens[t_] := 1/((1 - t)/f /@ xℱ + t/g /@ x\[ScriptCapitalG])

The resulting density can be visualized as

ListLinePlot[Evaluate@Table[{X[t], dens[t]}\[Transpose], {t, 0, 1, .1}]]

The transport map can also be computed and plotted with

dT = f /@ xℱ/g /@ x\[ScriptCapitalG];
T = Interpolation[{{xℱ}\[Transpose], x\[ScriptCapitalG], dT}\[Transpose]];
Plot[T[x], {x, xℱ[[1]], xℱ[[-1]]}]

# Symbolic solution

Mathematica appears to be able to deal with distributions, CDF, inverse CDF and pushforwards of distributions:

ℱ = UniformDistribution[-1 + {-1, 1}/2];
\[ScriptCapitalG] = TriangularDistribution[1 + {-1, 1}];
T[x_] = InverseCDF[\[ScriptCapitalG], CDF[ℱ, x]] // Simplify;
\[ScriptCapitalD][t_] := TransformedDistribution[(1 - t) x + t T[x], x \[Distributed] ℱ]
Plot[{PDF[ℱ, x], PDF[\[ScriptCapitalG], x]}, {x, -2, 2}]
Plot[Evaluate@Table[PDF[\[ScriptCapitalD][t], x], {t, 0., 1., .1}], {x, -2, 3}]

## Symbolic integration of UnitBox and UnitTriangle

While it's true that

Integrate[UnitBox[y], {y, -∞, x}]

and

Integrate[UnitTriangle[y], {y, -∞, x}]

do not work as intended, giving a slight hint regarding the domain of x helps in both cases

Integrate[UnitBox[y], {y, -∞, x}, Assumptions -> x ∈ Reals]
Integrate[UnitTriangle[y], {y, -∞, x}, Assumptions -> x ∈ Reals]

and the returned result are piecewise functions. An antiderivative can also be found with

Derivative[-1][UnitBox][x]
Derivative[-1][UnitTriangle][x]
• Thank you for providing a reference solution. However, it is explicitly asked for a numeric approach. Nov 5, 2019 at 15:34
• @yarchik You are right, I modified the answer to include a numeric approach. Nov 5, 2019 at 17:33
• Thanks a lot! Numerical solution works fine, but it is rather slow: 52s to compute InverseCDF for 61 point. This seems to be a well known problem of this function as shown here and here. In fact, efficiency is my biggest concern. I have 40 function pairs and some of them with sharp peaks that require many points. I hope someone can come up with a compiled solution. Nov 5, 2019 at 22:13
• This method is very lovely! Do you happen to have a good reference discussing this and related topics in detail? Nov 16, 2019 at 0:23

You can use NDSolveValue to create an interpolating function representation of the inverse. Basically, suppose you want to invert f. Then:

f[finv[x]] == x

where finv is the inverse function. So, an ODE for the inverse function is:

D[f[finv[x]] == x, x]

f'[finv[x]] finv'[x] == 1

Let's use this for your G function:

g[x_] := UnitTriangle[x-3]
G[x_] := Integrate[g[s], {s, -Infinity, x}]

Then we have:

Ginv = NDSolveValue[{G'[inv[x]] inv'[x] == 1, inv[G[3]] == 3}, inv, {x, 0, 1}]

However, it's easy to see that we can use g instead of G', so it will be quicker to do:

Ginv = Quiet @ NDSolveValue[{g[inv[x]] inv'[x] == 1, inv[G[3]] == 3}, inv, {x, 0, 1}];

The quieted messages are associated with the the fact that g is zero when x is at one of the endpoints, 0 or 1. Let's check:

G[Ginv[0]]
G[Ginv[.5]]
G[Ginv[.75]]
G[Ginv[1]]

0.

0.5

0.75

1.

So, Ginv is an interpolating function representation of the inverse of G, and you can take derivatives of it as desired, e.g.:

D[Ginv[Sin[x]], x] /. x->3

-1.86349