(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "NeXT Mathematica Notebook Front End Version 2.2"; NeXTStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e8, 24, "Times"; ; fontset = subtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e6, 18, "Times"; ; fontset = subsubtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, L1, e6, 14, "Times"; ; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, L1, a20, 18, "Times"; ; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, L1, a15, 14, "Times"; ; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, L1, a12, 12, "Times"; ; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 10, "Times"; ; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L1, 12, "Courier"; ; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; ; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, L1, 12, "Courier"; ; fontset = name, inactive, noPageBreakInGroup, nohscroll, preserveAspect, M7, italic, B65535, L1, 10, "Times"; ; fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, L1, 12, "Times"; ; fontset = leftheader, 12; fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, italic, L1, 12, "Times"; ; fontset = leftfooter, 12; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12, "Courier"; ; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; paletteColors = 128; automaticGrouping; currentKernel; ] :[font = title; inactive; preserveAspect; startGroup] Sound Bite Length for Presidential Election :[font = section; inactive; preserveAspect; startGroup] BRIEF ABSTRACT :[font = subsection; inactive; preserveAspect; endGroup] Over time the average length of uninterrupted speech offered by a Presidential candidate on the evening news has decreased. Where is the average length of these sound bites headed? We take data from a New York Times article and see if politicians are doomed to a "Yup!" "Nope!" soundbite in the future and if so when? :[font = section; inactive; Cclosed; preserveAspect; startGroup] GENERAL INFORMATION :[font = subsection; inactive; preserveAspect; endGroup] FileName: SOUNDBIT Full title: Sound Bite length for Presidential Election - Predictions Developer: Brian J. Winkel, Department of Mathematics, Rose-Hulman Institute of Technology, Terre Haute IN 47803 USA. Contact: Brian J. Winkel, Department of Mathematics, Rose-Hulman Institute of Technology, Terre Haute IN 47803 USA. Phone: 812-877-8412. Email: winkel@rose-hulman.edu. FAX: 812-877-3198. Support: The production of this material is supported by the National Science Foundation under Division of Undergraduate Education grant DUE-9352849: Development Site for Complex, Technology-Based Problems in Calculus with Applications in Science and Engineering and the Arvin Foundation of Columbus IN. :[font = section; inactive; Cclosed; preserveAspect; startGroup] STATEMENT OF PROBLEM :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The idea for this problem comes from a piece in the New York Times, 23 January 1992, by John Tierney, p. 1, entitled, Sound Bites Become Smaller Mouthfulls. The following data was given on the average uninterrupted time (in seconds) during which a Presidential candidate spoke in an appearance in the evening news for the years 1968, 1972, 1976, 1980, 1984, 1988. ;[s] 3:0,0;52,1;66,2;365,-1; 3:1,12,9,Times,1,14,0,0,0;1,13,10,Times,2,14,0,0,0;1,12,9,Times,1,14,0,0,0; :[font = input; preserveAspect] TimeList = {{1968,43.1}, {1972,25.2}, {1976, 18.2}, {1980,12.2}, {1984,9.9}, {1988,8.9}}; :[font = input; preserveAspect; endGroup] p1 = ListPlot[TimeList,PlotStyle->{PointSize[.02]}, PlotRange->{{1965,1996},{0,50}}, AxesLabel->{"Year", "SoundBite"}] :[font = subsection; inactive; preserveAspect; endGroup] The article says, "If this decline - 3.4 seconds in two years, or 0.17 seconds per yearover 20 years - were to continue at a linear rate, the average sound bite in 1992 would be 2 seconds long, perhaps something along the lines of `Me President, you voter.' A more conservative extrapolation would be in the range of 6.5 to 8.5 seconds, which could be enough for a complete clause." Based on this data, what do you predict will be the average sound bite for the Presidential candidates on the evening news in 1996? :[font = section; inactive; Cclosed; preserveAspect; startGroup] KEYWORDS :[font = subsection; inactive; preserveAspect; endGroup] Data, curve fitting, exponential function, prediction, sound bite, elections. :[font = section; inactive; Cclosed; preserveAspect; startGroup] TEACHER NOTES :[font = subsection; inactive; preserveAspect] ISSUES RELATED TO THE PROBLEM :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Prerequisites :[font = subsubsection; inactive; preserveAspect; endGroup] Knowledge of linear and exponential functions, curve fitting, say using least squrares approach, or eyeballing a fit of a curve to data. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Time allotment - time management :[font = subsubsection; inactive; preserveAspect; endGroup] This problem can be an in class discussion which should take no more than 20 minutes. OR it could be a small group project for, say 10 minutes in class, followed up as a homework assignment. I have used this twice successfully with students who have just learned about exponential functions and some notion of least squares fitting of curves to data. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Expectations :[font = subsubsection; inactive; preserveAspect; endGroup] We expect students to construct a model for the data, fit the model (i.e. determine parameters which fit "best"), and use it to predict the future. We also expect the students to question the wisdom of doing this in all cases. :[font = subsection; inactive; preserveAspect] Future payoffs :[font = subsection; inactive; preserveAspect] Extensions :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] References and Sources :[font = subsubsection; inactive; preserveAspect; endGroup; endGroup] The idea for this problem comes from a piece in the New York Times, 23 January 1992, by John Tierney, p. 1, entitled, Sound Bites Become Smaller Mouthfulls. ;[s] 3:0,0;52,1;66,2;158,-1; 3:1,10,8,Times,1,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,10,8,Times,1,12,0,0,0; :[font = section; inactive; Cclosed; preserveAspect; startGroup] POSSIBLE SOLUTION(S) :[font = subsection; inactive; preserveAspect] The data does not appear to be going to 0, but rather leveling off at a positive number, say b. :[font = subsection; inactive; preserveAspect] We seek to find the function of the form y = f(x) = Ae-kx + b which fits this data best in the sense that it minimizes the sum of the squares of the differences between the y values of the actual data, yi, and y values of the theoretical model, f(xi). ;[s] 7:0,0;54,1;57,2;204,3;205,4;251,5;252,6;255,-1; 7:1,12,9,Times,1,14,0,0,0;1,12,9,Times,33,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0; :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Let us try our hand at guessing a good A, k, and b and then try it out to see how well it fits. Enter the function below and to try your values for A, k, and b. Simply type in a command, e.g., try[10,.4,5]] will plot the function f(x) = 10 Exp[-.4 x] + 5 and the data. :[font = input; noPageBreakBelow; preserveAspect] try[A_,k_,b_] := Show[p1, Plot[A Exp[-k (x-1962)] + b,{x,1962,1996}, PlotRange->{0,10}, DisplayFunction->Identity] ] :[font = input; preserveAspect; endGroup] try[80,.12,5] :[font = subsection; inactive; Cclosed; noPageBreak; preserveAspect; startGroup] We enter our theoretical model, based on obervations or previous theory. We note there are three parameters, A, k, and b which need to be determined. :[font = input; preserveAspect; endGroup] f[x_] := A Exp[-k (x - 1962)] + b :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] We form the sum of the squares of the difference between the y values of the actual data,yi, and y values of the theoretical model, f(xi). Here SS[A,k,b] is a function of the two parameters, A , k, and b. TimeList[[i]][[1]] picks off the first element of each data pair, i.e. the xi, while TimeList[[i]][[2]] picks off the second element of each data pair, i.e. yi. Then f[TimeList[[i]][[1]]] actually computes the value of the theoretical function at xi. Finally, SS[A,k,b] computes the differences in these y values, squares them, and adds the sum of the square differences for all data in the TimeList set. ;[s] 11:0,0;92,1;93,2;139,3;140,4;287,5;288,6;369,7;370,8;461,9;462,10;686,-1; 11:1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0;1,12,9,Times,65,14,0,0,0;1,12,9,Times,1,14,0,0,0; :[font = input; preserveAspect; endGroup] SS[A_,k_,b_] = Sum[ (f[ TimeList[[i]][[1]]] - TimeList[[i]][[2]])^2, {i,1, Length[TimeList]}]; :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] We seek the values of A, k, and b] which minimize this sum of squares, SS[A, k, b]. :[font = input; Cclosed; preserveAspect; startGroup] vals = FindMinimum[SS[A,k,b],{A,80},{k,.12},{b,5}] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] {4.911169416817074, {A -> 82.0849434958114, k -> 0.1435587693465245, b -> 6.880699931513235}} ;[o] {4.91117, {A -> 82.0849, k -> 0.143559, b -> 6.8807}} :[font = subsection; inactive; preserveAspect] Hence we have values for A, k, and b. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] And our theoretical model appears to be: :[font = input; preserveAspect] ft[x_] := A Exp[-k (x - 1962)] + b/.vals[[2]] :[font = input; preserveAspect; endGroup] fPlot = Plot[ft[x],{x,1962,1996}] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] And now to see how good our fit is, we compare the theoretical plot, fPlot with the actual plot of the data :[font = input; preserveAspect; endGroup] Show[p1,fPlot] :[font = subsection; inactive; preserveAspect] Not too shabby...... :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] What will the average sound bite be in 1996? :[font = input; Cclosed; preserveAspect; startGroup] ft[1996] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] 7.503678257593895 ;[o] 7.50368 :[font = subsection; inactive; preserveAspect] Thus we expect to get about an average of 7.5 seconds of uninterrupted time for Presidential candidates in the evening news in 1996. Think on that!!!! :[font = subsection; inactive; preserveAspect; endGroup] This model would predict in the long run that the average length of a Presidental sound bite woulc approach b=6.8807, within the range of the article's claim. :[font = section; inactive; Cclosed; preserveAspect; startGroup] ISSUES IN SOLUTION :[font = subsection; inactive; preserveAspect] We have proposed a curve fitting model using a least squares approach. Students may prefer other functions and other approaches. :[font = subsection; inactive; preserveAspect] If this is an initial curve fitting exercise students may start with a linear fit, but issues such as what does it mean to eventually have a negative length for a sound bite feedback to the students and they begin to propose models which stay non-negative. :[font = subsection; inactive; preserveAspect; endGroup; endGroup] The issue of whether or not the sound bite length will go to zero eventually occurs when students use a pure exponential, for example f(t) = A Exp[ k t] without any added constant. ^*)