1
$\begingroup$

This is my first time posting a question in StackExchange. I have encountered a certain problem and I can't seem too find a solution. Just a word of caution, I am kind of an amateur when it comes to Mathematica and the Wolfram language.

What I would like to do is create a graph of a function y=f[x], to illustrate the difference between optimal ("pointy" edge) and robust ("blunt" edge) solutions.

In the same graph/plot, I would like to show the distribution of the X quantity, correctly placed on the x-axis (under the pointy and blunt edges), as well as the corresponding distributions (preferably Smooth Histograms) of each Y quantity, also correctly placed, but vertically on the y-axis this time.

I have accomplished the first part, but I can't seem to find a way to place the y distributions too.

One way I have thought of facing this problem is to create the two Y-distributions and place them as transposed images on the plots plot. However, my programming abilities limit my end result.

This (low quality) picture I created in Photoshop, illustrates what I would like to do.

Optimal vs Robust Design

Please help!!

Below is the code I am using.

PS: any other comment, hint or piece of advise is greatly appreciated.

PPS: I also can't get the monochromatic theme to work for the plots plot

f[x_]=InterpolatingPolynomial[{ { 3.61 ,7.29}, { 5.27, 2.21}, { 6.00, 4.00}, { 6.48, 6.68}, { 8.20, 7.30}, { 9.37, 6.31}, {10.25, 4.92}, {11.26, 3.52}, {12.40, 3.48}, {13.44, 3.48}, {14.28, 3.76}, {15.39, 6.58}, {15.90, 8.62} },x]
FindMinimum[f[x],{x,5}]

Result of FindMinimum: {1.69509,{x->5.45853}}, the value of which I use in mopt, for the pointy edge. For the blunt edge, mrob=12.5 seemed like a good guess.

mopt = 5.45853;
sopt = 0.5;
mrob = 12.5;
srob = sopt;
grob[x_] = PDF[NormalDistribution[mrob,srob],x];
gopt[x_] = PDF[NormalDistribution[mopt,sopt],x];

plots=Show[ Plot[ f[x],
                  {x,0,20},
                  RegionFunction->Function[{x,y},3.95<x<15.5],
                  PlotLegends->{"F(x)"},
                  PlotStyle->{Thick, Blue}
                 ],
            Plot[ grob[x],
                  {x,0,20},
                  RegionFunction->Function[{x,y},-srob<(x-mrob)/3<srob],
                  Filling->Axis,
                  PlotLegends->{"Nrob"},
                  PlotStyle->{Red, Dashing[Tiny]}
                 ],
            Plot[ gopt[x],
                  {x,0,20},
                  RegionFunction->Function[{x,y}, -sopt<(x-mopt)/3<sopt],
                  Filling->Axis,
                  PlotLegends->{"Nopt"},
                  PlotStyle->{Green,Dashed}],
                  AxesLabel->{"x","F"},
                  Ticks->None,
                  Axes->{True,True},
                  PlotRange->{{0,17},{0,14}}
                 ]

All in order to export it as an .eps image file.

Export["robustdesignFinal.eps",plots]

The two graphs I would like to add are essentially the ones below:

datarob=RandomVariate[NormalDistribution[mrob, srob],10000]
dataopt=RandomVariate[NormalDistribution[mopt, sopt],10000]
Adatarob=f[datarob]
Adataopt=f[dataopt]
h1=SmoothHistogram[ Adatarob,
                    Automatic,
                    "PDF",
                    RegionFunction->Function[{x,y},3.3<x<3.6],
                    PlotRange->{{3.3,3.6},{0,15}},
                    Filling->Axis,
                    PlotLegends->{"P(Frob)"},
                    PlotStyle->{Red, Dashing[{0.01,0.02}]},
                    Axes->False
                   ]

h2=SmoothHistogram[ Adataopt,
                    Automatic,
                    "PDF",
                    RegionFunction->Function[{x,y},0<x<10],
                    PlotRange->{{0,10},{0,0.5}},
                    Filling->Axis,
                    PlotLegends->{"P(Fopt)"},
                    PlotStyle->{Green,Dashing[{0.02,0.04}]},
                    Axes->False
                   ]
$\endgroup$
  • $\begingroup$ I'm not sure exactly what you mean. Can you include an example figure from some other source as a reference perhaps? Also, I'm pretty confused by the FindMinimum on that interpolating function, given that you've specified no constraints, which means the minimum is -infinity. $\endgroup$ – march Aug 29 '15 at 2:20
  • $\begingroup$ Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory Tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. $\endgroup$ – bbgodfrey Aug 29 '15 at 4:02
  • $\begingroup$ @grampalis, what are those Adatarob and Adataorb stuff? $\endgroup$ – garej Aug 29 '15 at 9:34
  • $\begingroup$ @bbgodfrey thanks. i will have them in mind! $\endgroup$ – gpampalis Aug 29 '15 at 12:13
  • $\begingroup$ @march I included a low quality figure i made myself using Photoshop. Concerning the FindMinimum, firstly i am only interested in this specific region of the function 3.95<x<15.5 which demonstrates what i would like to explain in my essay. And secondly the interpolating function results in a 12th degree polynomial, even highest degree, with a positive coefficient for x^12. So, the minimum is a real number. $\endgroup$ – gpampalis Aug 29 '15 at 12:20
2
$\begingroup$

Here are the modifications that need to be done on your plots h1 and h2 in order to flip them over the line y == x. If you look "under the hood" at the structure of these two plots by executing, for instance,

FullForm@Normal@h1

you find that really there are only two objects, a Line and a Polygon. Both of these Heads take inputs which are lists of {x, y} lists, so all we need to do is go in "by hand" and reverse each one of these coordinate lists. To do this, we define a replacement rule

rule = {Line[a_] :> Line[Reverse /@ a], Polygon[a_] :> Polygon[Reverse /@ a]};

which will take all objects in an expression of the form Line[ something ] and Map Reverse over the something. In other words, we switch x and y in each of the coordinate lists inside something.

Then, we define new plots

h1New = Normal@h1 /. rule

h2New = Normal@h2 /. rule

For convenience, let's suppose that you called the Plots for f[x], grob[x], and gopt[x]

plotF, plotgrob, and plotgopt

respectively. Then your final figure can be made using

plots = Show[plotf, plotgrob, plotgopt, h1New, h2New
  , AxesLabel -> {"x", "F"}
  , Ticks -> None
  , Axes -> {True, True}
  ,PlotRange -> {{0, 17}, {0, 14}}
]

Resulting in

enter image description here

Note that these are the correct histograms exactly as computed using SmoothHistogram, and it turns out that the red one is very narrow and tall and the green one is wide and short. If you don't care that the histograms need to be exact, we can play around a little with the values. I played around a little and came up with

h1New = Normal@h1 /. rule /. (pat : Line | Polygon)[x_] :> pat[{1/3 #1, 3.5 + 5 (#2 - 3.5)} & @@@ x]

which stretches the red histogram by a factor of 5 vertically about the y-value 3.5 at the same time that it scales the x-values by a factor of 1/3, and

h2New = Normal@h2 /. rule /. (pat : Line | Polygon)[x_] :> pat[{5 #1, #2} & @@@ x]

which stretches the green plot horizontally by a factor of 5. The result is

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ Wow!! Thank you so much. I especially like the playing-around addition. I will be accepting your answer as a solution shortly!! $\endgroup$ – gpampalis Aug 30 '15 at 23:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.