Create filling between two trig functions

Question

Working with trig functions, period, amplitude, etc.

I found a worksheet at a calculus website, with some nice questions related to interpreting trig functions, at least, they provide some "fun" context.

It has to do with a couple, different phases in their relationship, etc.

See http://math.arizona.edu/~calc/m124/Denise&Chad.pdf

Anyway, my Mathematica question, is related to filling between two curves.

In the worksheet, consider that "happy" means positive. A couple is “happy” when they both like each other. A couple is unhappy when they both dislike each other.

Here are the two curves as given in the worksheet.

Plot[{Sin[9 \[Pi] t/10], 2 Sin[7 \[Pi] t/10]}, {t, 0, 20}, 
 AspectRatio -> 0.2, AxesLabel -> {"weeks", "affection"}]

Is there a clever Mathematica way to fill in just those portions of the curve where the couple are happy, I.E. both are positive? Is there a nice way to visualize this?

Answer 1

Seems incredibly wasteful to repeat the plots but this does at least work. Notice the use of ColorFunctionScaling->False. This is necessary here.

Show[
  Plot[{2 Sin[7 \[Pi] t/10],Sin[9 \[Pi] t/10]}, {t, 0, 20}, Filling -> Axis, 
   ColorFunctionScaling -> False, 
   ColorFunction -> 
    Function[{x, y}, 
     If[2 Sin[7 \[Pi] x/10] > 0 && Sin[9 \[Pi] x/10] > 0, Green, 
      Red]]]
  , 
  Plot[{2 Sin[7 \[Pi] t/10], Sin[9 \[Pi] t/10]}, {t, 0, 20}, 
   PlotStyle -> Black], 
    AxesLabel -> {"weeks", "affection"}, AspectRatio -> .2
 ]

Edit:

You could alternatively use RegionPlot to do the shading. The PlotPoints need to be set quite high to pick up the smaller regions.

Show[Plot[{2 Sin[7 \[Pi] t/10], Sin[9 \[Pi] t/10]}, {t, 0, 20}, 
  AxesLabel -> {"weeks", "affection"}, AspectRatio -> .2], 
 RegionPlot[
  2 Sin[7 \[Pi] t/10] > 0 && Sin[9 \[Pi] t/10] > 0, {t, 0, 
   20}, {y, -4, 4}, PlotStyle -> Directive[Opacity[.25], Green],
 PlotPoints -> 250]]

Edit 2:

I seem to be unable to stop having fun with this one. It is much faster to use Plot with Boole than to use RegionPlot in this case since the regions are simple rectangles.

Show[Plot[{2 Sin[7 \[Pi] t/10], Sin[9 \[Pi] t/10]}, {t, 0, 20}, 
  AxesLabel -> {"weeks", "affection"}, AspectRatio -> .2], 
 Plot[{-2, 2} Boole[
    2 Sin[7 \[Pi] t/10] > 0 && Sin[9 \[Pi] t/10] > 0], {t, 0, 20}, 
  Filling -> Axis, PlotStyle -> None, 
  FillingStyle -> Directive[Opacity[.5], Pink], PlotPoints -> 150]]

Answer 2

Here's happy:

Plot[{Sin[9 \[Pi] t/10], 2 Sin[7 \[Pi] t/10]}, {t, 0, 20}, 
 AspectRatio -> 0.2, AxesLabel -> {"weeks", "affection"}, 
 Filling -> {1 -> {Axis, {None, Green}}, 1 -> {{2}, White}}]

Answer 3

may be another option

f1[t_] := Sin[9 Pi t/10];
f2[t_] := 2 Sin[7 Pi t/10];
data=Table[{t,If[f1[t]>0 && f2[t] > 0, Max[{f1[t],f2[t]}], 0]},{t,0,20,0.01}];
p1 = ListPlot[data, Joined -> True, Filling -> Axis,FillingStyle -> Green];
p2 = Plot[{f1[t], f2[t]}, {t, 0, 20},AxesLabel->{"weeks","affection"},Evaluated -> True];
Show[p2, p1]

Answer 4

 {f1, f2} = {Sin[9 \[Pi] t/10], 2 Sin[7 \[Pi] t/10]};
 Plot[{f1, f2, ConditionalExpression[#, # >= 0] &[Min[f1, f2]]}, {t, 0, 20},
 Filling -> {3 -> {Axis, Green}}, PlotStyle -> Thick,
  AspectRatio -> 0.2, Frame -> False, Axes -> False]

(Axes removed to show that the added function does not produce a line at zero.)

Answer 5

To answer the second, rather different question concerning the percentage of time the couple are happy, here is one way of calculating it:-

(* Find roots up to t = 20 (period of sin(ax) is 2 Pi/a) *)
r1 = Table[t, {t, 0, 20, 10/9}];
r2 = Table[t, {t, 0, 20, 10/7}];

(* Establish when going positive *)
d1 = Sign[D[Sin[9 \[Pi] t/10], t] /. t -> r1];
d2 = Sign[D[2 Sin[7 \[Pi] t/10], t] /. t -> r2];

(* Join in a list for processing *)
m1 = Transpose[{r1, d1, ConstantArray[0, Length[r1]]}];
m2 = Transpose[{r2, ConstantArray[0, Length[r2]], d2}];
m = Sort[Join[m1, m2]];

process[{a_, b_, c_}] := Module[{},
  Which[b == 1, y = 1, b == -1, y = 0];
  Which[c == 1, z = 1, c == -1, z = 0];
  AppendTo[list, If[y + z == 2, {"happy", a}, {"not so happy", a}]]]

y = z = 0;
list = {};

process /@ m;

ToString[First[Total[
      {Last[#2] - Last[#1]} & @@@ Cases[Partition[list, 2, 1],
        {{"happy", _}, _}]]/20*100.]] <> "%"

25.3968%