1
$\begingroup$

I'm working with the code from the Riemann Sums Wolfram Demonstration. I'm modifying some of the functions linked to in the controls. When I do this, in certain cases the axes don't generate correctly. For example, when I change x-1 to x+1. Code is below and screenshot of the incorrect graphical rendering is attached. Any suggestions on where the problem might lie?

Manipulate[
 RiemannBlocks[FunctionF[x][[fff]], {x, 0, 5, blocks}, 
  type], {{blocks, 39, "number of rectangles"}, 4, 70, 1, 
  Appearance -> "Labeled"}, 
   {{type, 2, "height"}, {1 -> "left", 2 -> "midpoint", 
   3 -> "right"}}, {{fff, 4, "function"}, {1 -> "x - 1", 
   2 -> "\!\(\*SuperscriptBox[\(x\), \(2\)]\) + 1", 
       3 -> "\!\(\*SuperscriptBox[\(x\), \(3\)]\) - 1", 
   4 -> "log( x + 1 )", 
   5 -> "( 1 - x \!\(\*SuperscriptBox[\()\), \(2\)]\)", 
   6 -> "\[LeftBracketingBar] x - 2 \[RightBracketingBar]", 
   7 -> "cos( x )", 
       8 -> 
    "\!\(\*SqrtBox[\(\[LeftBracketingBar]\\ x - \
1\[RightBracketingBar]\)]\)"}, ControlType -> Setter}, 
 ControllerLinking -> True, 
   Initialization :> {RiemannBlocks[f_, {x_, a_, b_, n_}, type_] := 
    Plot[f, {x, a, b}, 

     Prolog -> Table[({{RGBColor[0.2, 0.5, 0.79], Polygon[#1]}, 
           Line[Append[#1, #1[[1]]]]} & )[(BlockCoords[#1, #2, 
            Sample[f, {x, #1, #2}, type]] & )[a + i*((b - a)/n), 
                   a + (i + 1)*((b - a)/n)]], {i, 0, n - 1}], 
     ImagePadding -> {{25, 25}, {25, 50}}, 

     PlotLabel -> 
      StringJoin["estimated area = ", 
       ToString[
        NumberForm[(b - 
            a)*(Sum[
             IsReal[Sample[
               f, {x, a + i*((b - a)/n), a + (i + 1)*((b - a)/n)}, 
               type]], {i, 0, n - 1}]/n), 
                   {7, 4}, NumberPadding -> {"", "0"}]], "\n", 
       "actual area = ", 
       ToString[
        NumberForm[
         Check[Chop[NIntegrate[f, {x, a, b}, AccuracyGoal -> 12]], 
          I], {7, 4}, 
                   NumberPadding -> {"", "0"}]]]], 
   BlockCoords[a_, b_, h_] := {{a, 0}, {a, h}, {b, h}, {b, 0}}, 
   Sample[f_, {x_, a_, b_}, type_] := 
         {LeftValue[f, {x, a, b}], MidpointValue[f, {x, a, b}], 
      RightValue[f, {x, a, b}]}[[type]], 
   LeftValue[f_, {x_, a_, b_}] := N[f /. x -> a], 
       MidpointValue[f_, {x_, a_, b_}] := N[f /. x -> (a + b)/2], 
   RightValue[f_, {x_, a_, b_}] := N[f /. x -> b], 
       IsReal[x_] := 
    Module[{}, 
     If[ ! NumericQ[x] || Im[x] != 0, 
      Throw["One or more samples are outside the domain."]]; x], 
       FunctionF[x_] := {x - 1, x^2 + 1, x^3 - 1, 
     Log[x + 1], (1 - x)^2, Abs[x - 2], Cos[x], Sqrt[Abs[x - 1]]}}]

Incorrect axis

$\endgroup$
1
$\begingroup$

The problem is that the y-range of the curve in Plot is different than the rectangles drawn in the Prolog.

The fix I tried was to move the computation of the polygons outside of Prolog into a module. Define a variable, ymin to represent the minimum of the polygons and zero.

Set the AxesOrigin y-value to ymin.

I did not thoroughly test but at least it works for the `x+1 case and you should be able to tweak it from there.

Manipulate[
 RiemannBlocks[FunctionF[x][[fff]], {x, 0, 5, blocks}, type],

 {{blocks, 39, "number of rectangles"}, 4, 70, 1, 
  Appearance -> "Labeled"}, {{type, 2, "height"}, {1 -> "left", 
   2 -> "midpoint", 3 -> "right"}}, {{fff, 4, "function"},
  {1 -> "x + 1", 2 -> "\!\(\*SuperscriptBox[\(x\), \(2\)]\) + 1", 
   3 -> "\!\(\*SuperscriptBox[\(x\), \(3\)]\) - 1", 
   4 -> "log( x + 1 )", 
   5 -> "( 1 - x \!\(\*SuperscriptBox[\()\), \(2\)]\)", 
   6 -> "\[LeftBracketingBar] x - 2 \[RightBracketingBar]", 
   7 -> "cos( x )", 
   8 -> "\!\(\*SqrtBox[\(\[LeftBracketingBar]\\ x - 1\
\[RightBracketingBar]\)]\)"}, ControlType -> Setter},

 ControllerLinking -> True,

 Initialization :> {
   RiemannBlocks[f_, {x_, a_, b_, n_}, type_] :=
    Module[
     {
      table = 
       Table[({{RGBColor[0.2, 0.5, 0.79], Polygon[#1]}, 
            Line[Append[#1, #1[[1]]]]} &)[(BlockCoords[#1, #2, 
             Sample[f, {x, #1, #2}, type]] &)[a + i*((b - a)/n), 
          a + (i + 1)*((b - a)/n)]], {i, 0, n - 1}],
      ymin
      },
     ymin = Min[Cases[table, {x_, y_Real} :> y, Infinity]];
     ymin = Min[0, ymin];
     Show[
      Plot[f, {x, a, b},
       AxesOrigin -> {0, ymin},
       ImagePadding -> {{25, 25}, {25, 50}}, 
       PlotLabel -> 
        StringJoin["estimated area = ", 
         ToString[
          NumberForm[(b - 
              a)*(Sum[
               IsReal[Sample[
                 f, {x, a + i*((b - a)/n), a + (i + 1)*((b - a)/n)}, 
                 type]], {i, 0, n - 1}]/n), {7, 4}, 
           NumberPadding -> {"", "0"}]], "\n", "actual area = ", 
         ToString[
          NumberForm[
           Check[Chop[NIntegrate[f, {x, a, b}, AccuracyGoal -> 12]], 
            I], {7, 4}, NumberPadding -> {"", "0"}]]]],
      Graphics[
       table
       ]
      ]
     ],

   BlockCoords[a_, b_, h_] := {{a, 0}, {a, h}, {b, h}, {b, 0}},

   Sample[f_, {x_, a_, b_}, 
     type_] := {LeftValue[f, {x, a, b}], MidpointValue[f, {x, a, b}], 
      RightValue[f, {x, a, b}]}[[type]],

   LeftValue[f_, {x_, a_, b_}] := N[f /. x -> a],

   MidpointValue[f_, {x_, a_, b_}] := N[f /. x -> (a + b)/2],

   RightValue[f_, {x_, a_, b_}] := N[f /. x -> b],

   IsReal[x_] := 
    Module[{}, 
     If[! NumericQ[x] || Im[x] != 0, 
      Throw["One or more samples are outside the domain."]]; x],

   FunctionF[x_] := {x + 1, x^2 + 1, x^3 - 1, Log[x + 1], (1 - x)^2, 
     Abs[x - 2], Cos[x], Sqrt[Abs[x - 1]]}
   }
 ]

(* Don't ask my why the red color, works fine in the notebook *)

Mathematica graphics

$\endgroup$
  • $\begingroup$ Thank you so much! I tested it further and it appears to be fixed for my purposes. I really appreciate the help! $\endgroup$ – rowancat Oct 16 '17 at 0:00

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.