Seeing Concavity:
A demo to illustrate the concavity of a function ƒ

Concept and direction:  Stan Wagon, Macalester College
Implementation:  Ruth Dover, IL Math & Science Academy

This notebook represents an attempt at showing the concavity of the graph of a function ƒ.  You are asked to enter a function, choose the domain, and then the number of frames for the animation.  (Around 10 or 12 is usually good.  Unlike many animations, more frames can make the changes more difficult to see.)  
	The first graph shows the graph of the function.  At each point in the animation, a section of a tangent line to the function is drawn.  At a nearby point, another tangent is drawn.  A reddish polygon (almost a triangle) is drawn along with a vertical segment showing the vertical change in the tangent lines. These same vertical segments are drawn (rescaled) in the second graph, along with the second derivative function.  (Note that these vertical segments are approximations only, and they may not closely match the actual second derivative.)
	The basic command is:
		Concavity[func, {x, xmin, xmax}, frames]
	An example is given.  Information in magenta may be edited and graphics options may be added.

Concavity[(x^3) - 6  x + 2, {x,-3, 3},12]

initialization

Clear[x, f,  Concavity];
Off[General::spell1];
Needs["Utilities`FilterOptions`"];
Needs["Graphics`"];
\(Concavity::usage = \*""Concavity[f, {x, xmin, xmax}, n] generates a movie that 
illustrates the second derivative of a function ƒ from xmin to xmax with n frames.  The first graph shows (relative) changes in the first derivative by considering tangent lines at nearby points.  These changes are rescaled in the second graph and shown with (ƒ^′)′."";\)
Concavity[g_,  {u_,  xmin_, xmax_},  frames_,  opts___]:=
Module[{step, h, a, f, fder,  fsecder,  pts,  trianglered,  
            rightside, midgr, ln,  ylow,  yhi, secderivpl,  yseclow,  
            ysechi, fstgr, laststep,  plder, lastgr,  lgr},
f[x_] := Function[u,  Evaluate[g]][x];
fder[x_] := Evaluate[f'[x]];
fsecder[x_] := 
              Evaluate[f''[x]];
step = 
              N[(((xmax - xmin))/(frames - 1))];
h = step/3;
a = frames/5;

  
secderivpl = 
              Plot[fsecder[x],  {x,  xmin,  xmax},  
                DisplayFunction -> Identity];
yseclow = 
              Min[0,  PlotRange[secderivpl][[2,  1]]];
ysechi = 
              Max[0,  PlotRange[secderivpl][[2,  2]]];

  

trianglered = 
              Table[{VioletRed,  
                  Polygon[{{t + a step,  
                        f[t + h] + fder[t + h] (a step - h)},  {t + 
                          h,  f[t + h]}, {t,  f[t]},  {t + a step, 
                        f[t] +  a fder[t] step}}]},  {t,  xmin,  
                  xmax,  step}];
pts = Table[ {t, f[t]},  {t,  xmin,  xmax,  step}];
rightside = 
              Table[ {If[fsecder[t] > 0,  Cyan,  DodgerBlue], 
                  Thickness[ .014], 
                  Line[{{ t + a step,  
                        f[t + h] + fder[t + h] (a step - h)}, {t + 
                          a step, f[t] +  a fder[t] step}}]},  {t,  
                  xmin, xmax, step}];

midgr=Table[{If[fsecder[t + h/2] > 0,  Cyan,  
                        DodgerBlue],Thickness[ .014],Line[{{ 
                              t, (1/80) (ysechi - yseclow)*
                                Sign[fsecder[t + h/2]]},{t, (36 ( .42  
                                        frames -  .53)/(((xmax - xmin))^2))*((f[t + h] + fder[t + h] (a step - h)) - (f[
                                        t] +  a fder[t] step))}}]}, {t,  xmin, xmax, step}];
ln = {Thickness[ .012], 
                Line[{{xmin - (1/20) (xmax - xmin),  
                      0},  {xmax + (1/20) (xmax - xmin),  0}}]};


  
funcplot = 
              Plot[f[x],  {x,  xmin  - (1/12) (xmax - xmin),  
                  xmax + (1/12) (xmax - xmin)},  
                PlotRange -> All, DisplayFunction -> Identity];
ylow = 
              Min[PlotRange[funcplot][[2, 1]], 
                Table[f[k] + a fder[k] step,  {k,  xmin,  xmax,  
                    step}],  
                Table[ f[k + h] + fder[k + h] (a step) ,  {k,  
                    xmin,  xmax - step,  step}]  ];
yhi = 
              Max[PlotRange[funcplot][[2, 2]], 
                Table[f[k] + a fder[k] step,  {k,  xmin,  xmax,  
                    step}], 
                Table[ f[k + h] + fder[k + h] (a step) ,  {k,  
                    xmin,  xmax - step, step}]];


  
fstgr[i_]:=
DisplayTogether[Graphics[{ 
                      Take[trianglered,  i], 
Take[
                        rightside, i]}],
Plot[
                    f[x],  {x,  xmin  - (1/20) (xmax - xmin),  
                      xmax + (1/20) (xmax - 
                              xmin)},   PlotStyle -> 
                      Thickness[ .012]],Graphics[{CadmiumYellow,  PointSize[ .026],  
                      Point  /@ Take[pts, i]}],Axes -> True,Evaluate[FilterOptions[Graphics, opts]],PlotLabel->
StyleForm[StringForm["ƒ(x) = ``", TraditionalForm[f[x]]],FontSize -> 18,FontFamily -> "Times",FontWeight -> "Bold",FontColor -> Navy ],PlotRange -> {{ 
                        xmin  - (1/20) (xmax - xmin),  
                        xmax +  .5  
                            a step + (1/20) (xmax - xmin)}, {ylow, 
                        yhi}}];

laststep = (((xmax - xmin))/frames);
plder[w_] := 
              Plot[Evaluate[fsecder[x]],  {x,  w,  w +  laststep}, 
                PlotStyle ->  Thickness[ .012], 
                DisplayFunction ->  Identity];
    lgr = 
              Table[plder[w],  {w,  xmin, xmax - laststep,  laststep}];

lastgr[i_]:=DisplayTogether[{Graphics[{Take[midgr, i],  ln}], 
                    Take[lgr,  i]},PlotRange -> {{ 
                        xmin  - (1/20) (xmax - xmin) -  .025, 
                        xmax + (1/20) (xmax - xmin)}, {yseclow,  
                        ysechi}},PlotLabel->
StyleForm[StringForm["(ƒ^′)′(x) = ``", TraditionalForm[fsecder[x]]],FontSize -> 18,FontFamily -> "Times",FontWeight -> "Bold",FontColor -> Navy ],Evaluate[FilterOptions[Graphics, opts]],Axes -> True];

  
Do[
              t = xmin + 
                  i step; 
DisplayTogetherArray[{fstgr[i], 
                  lastgr[i]},  ImageSize -> 600, 
                DisplayFunction -> $DisplayFunction],  {i,  1 ,  
                frames}]
]