I'm attempting to combine two problems that were previously addressed in the questions below:
- Filling an area between two curves with respect to a color function
Adding a gradient filling according to a given function between two curves
Can I make a plot with gradient filling?
- Rotating a plot, something trivial which I find ridiculously difficult doing in mathematica
How to rotate the curve but not the axes?
Here is an example, in which I've tried to simplify as much as possible from my own problem:
Consider the two following curves
list1 = {2.6, 3.9, 5.0, 6.3, 7.6, 8.7, 10.0, 11.3, 12.4, 13.7, 15.0,
16.1, 17.5, 18.6, 19.8, 21.1};
list2 = {0.9, 1.0, 1.3, 4.4, 4.5, 4.9, 7.9, 8.0, 8.6, 11.4, 11.5,
14.7, 14.8, 15.1, 18.2, 18.3};
f1 = Interpolation[
Thread[{Table[i, {i, 0, 3, N[3/(Length[list1] - 1)]}], list1}]];
f2 = Interpolation[
Thread[{Table[i, {i, 0, 3, N[3/(Length[list2] - 1)]}], list2}]];
Plot[{f1[t], f2[t]}, {t, 0, 3}]
I would like to fill the area between them with a function that changes with repsect to the distance between the two curves:
tmp2 = Table[i, {i, 0, 5, 0.1}];
Y = Interpolation[
Thread[{tmp2, Table[Sqrt[r], {r, 0, 1, N[1/(Length[tmp2] - 1)]}]}]]
Plot[Y[z], {z, 0, 5}]
c[x_, y_, z_] := (y Exp[-2 y x])/( 1 + y Exp[-2 y z ])
Plot[c[x, Y[1], 1], {x, 0, 2}, PlotRange -> All,
PlotStyle -> Thickness[0.025],
ColorFunction ->
Function[{x},
Blend[{ColorData["TemperatureMap", 0],
ColorData["TemperatureMap", 1]}, c[x, Y[2], 2]]]]
Plot[c[x, Y[4], 4], {x, 0, 4}, PlotRange -> All,
PlotStyle -> Thickness[0.025],
ColorFunction ->
Function[{x},
Blend[{ColorData["TemperatureMap", 0],
ColorData["TemperatureMap", 1]}, c[x, Y[4], 4]]]]
As u can see above, the Profile of the function is dependent on the distance between the two curves, both directily, and in-directly with Y
.
I would like to have this profile rotated, with the horizontal filling between the two rotated curves is given by the function above, something like:
Here are my abortive attempts so far
Plot[{f1[t], f2[t]}, {t, 0, 3}, Filling -> {1 -> {2}},
ColorFunctionScaling -> False,
ColorFunction ->
Function[{x, y},
Blend[{ColorData["TemperatureMap", 0],
ColorData["TemperatureMap", 1]},
c[(y - f2[x])/(f1[x] - f2[x]), Y[f1[x] - f2[x]], f1[x] - f2[x]]]]]
pp1 = Plot[{f1[t], f2[t]}, {t, 0, 3}]
axisRotate = # /. {x_Point | x_Line | x_GraphicsComplex :>
MapAt[(#.{{0, -1}, {1, 0}}) &, x, 1]} &;
Show[axisRotate@pp1, PlotRange -> {{10, 30}, {-5, 0}},
AspectRatio -> GoldenRatio/1]
Any help will be appreciated.