# Axes incorrectly generated using Plot

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},
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},
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]]}}]


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},

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 *)

• Thank you so much! I tested it further and it appears to be fixed for my purposes. I really appreciate the help! Oct 16, 2017 at 0:00