Morphing between two functions

Question

Assume we have 2 peaked positive functions

f[x_] := Exp[-(x + 3)^2]
g[x_] := 1/2 Exp[-(x - 3)^2/4]

that look like

Would it be possible to numerically find a morphed function such as

h[x_] := 2/3 Exp[-4 (x)^2/9]

(depicted below as orange)? Notice, linear interpolation (blue) fails miserably as the graph below shows.

Please, assume some blackbox functions. It is clear that the problem is very simple when an analytical expression is given.

Because of the fuzzy formulation, the solution cannot be unique.

Answer 1

You might be interested in the approach with optimal transport.

Let $F(x)=\int_{-\infty}^x f(y)\,dy$ and $G(x)=\int_{-\infty}^x g(y)\,dy$ be the repartition functions. Then $T(x)=G^{-1}\bigl(F(x)\bigr)$ is the optimal transport map from $f$ to $g$. The map $T_t(x)=(1-t)x+tT(x)$ is the displacement geodesic, so that the intermediate densities are given by $(T_t)_\#f$.

f[x_] := Exp[-(x + 3)^2]
g[x_] := 1/2 Exp[-(x - 3)^2/4]
F[x_] = Integrate[f[x], {x, -\[Infinity], x}];
G[x_] = Integrate[g[x], {x, -\[Infinity], 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]

In the case of Gaussians, as in your example, the interpolation is still Gaussian, and the explicit formula can be found here or here or here...

Answer 2

Clear["Global`*"]

f[x_] := Exp[-(x + 3)^2]
g[x_] := 1/2 Exp[-(x - 3)^2/4]

Treating f and g as unnormalized distributions

distf = ProbabilityDistribution[f[x],
   {x, -Infinity, Infinity}, Method -> "Normalize"];

distg = ProbabilityDistribution[g[x],
   {x, -Infinity, Infinity}, Method -> "Normalize"];

disth = TransformedDistribution[(x + y)/2,
   {x \[Distributed] distf, y \[Distributed] distg}];

data = RandomVariate[disth, 1000];

h[x_] = Integrate[f[x] + g[x], {x, -Infinity, Infinity}]*
  PDF[EstimatedDistribution[data,
    NormalDistribution[m, s]], x]

(* 1.81073 E^(-0.819682 (0.0440864 + x)^2) *)

Plot[{f[x], g[x], h[x]}, {x, -10, 10},
 PlotRange -> All,
 PlotLegends -> Placed["Expressions", {.75, .6}]]

EDIT: Or for a zero mean

h[x_] = Integrate[f[x] + g[x], {x, -Infinity, Infinity}]*
  PDF[EstimatedDistribution[data,
    NormalDistribution[0, s]], x]

(* 1.81039 E^(-0.819382 x^2) *)

Plot[{f[x], g[x], h[x]}, {x, -10, 10},
 PlotRange -> All,
 PlotLegends -> Placed["Expressions", {.75, .6}]]