Organizing and Summarizing Data

Cumulative Relative Frequency Charts

Lesson Overview

Goals
Students will be able to describe the steps needed to create a Cumulative Relative Frequency Chart.
Students will be able to create a Cumulative Relative Frequency Chart from data provided.

DisplayTable[data_List,opts:OptionsPattern[]]:=CellPrint[TextCell[Labeled[Grid[data,FilterRules[{opts},Options[Grid]],Frame->All,ItemSize->5,Alignment->Center,BaseStyle->{FontFamily->"Helvetica",FontSize->18},Background->LightYellow,Frame->All,Spacings->{2,0.62}],Style[OptionValue[TableLabel],FontFamily->"Times",16]],"Output",ShowStringCharacters->False,Background->None]]
Options[DisplayTable]=Join[{TableLabel->"Table label"},Options[Grid]];

Instructor Presentation

Introduction

When Quantitative data is collected, we often want to determine how the individual data elements relate to one another and to the whole data set.  This lesson plan outlines several common techniques to help turn raw data into information using a Cumulative Relative Frequency Charts.
Lets start with a small data set consisting of the three-year growth rates for mutual funds in the years preceding 2007.

returns=Sort[{13.5,13.16,10.53,14.74,13.20,12.24,12.61,19.11,14.47,12.29,13.92,16.16,12.07,10.99,15.07,10.06,14.14,12.77,19.74,12.76,13.34,11.32,15.41,17.37, 13.51,15.44,15.10,17.13,12.37,16.34,11.34,10.57,15.70,13.28,23.76,22.68, 14.81,23.54, 19.65,14.07,12.00}];
ListPlot[returns,Filling -> Axis,AxesOrigin->{0,0}]

We find this plot too busy, so what we want to do is break the data into small bins.  Each bin is defined by small ranges that when combined make up the entire span from the minimum data element to the maximum data element.  The bins we create can contain anywhere from zero to many data elements.  To accomplish this we must find the minimum data value and the maximum data value.  We also deside how many data bins that would be appropriate for our plot.

min =IntegerPart[Min[returns]]
max=IntegerPart[Max[returns]+1]
groups=7

Once we have these values we can then calculate things like the bin widths, the lower bin values and the upper bin values.

width=Round[(((IntegerPart[Max[returns]+1]-IntegerPart[Min[returns]]))/groups)]
lower=Table[IntegerPart[Min[returns]]+(n-2),{n,2,(2 groups),width}];
upper=Table[IntegerPart[Min[returns]]+n-.01,{n,2,(2 groups),width}];

Once we have the data set and appropriate , we really would like to tally the number of individual data elements.  To tally, we count up the number of each data element.  We list the data element in the left column and place the number of individual data elements directly to the right of the data element.  The result is what is know as a Frequency Table.

counts=BinCounts[returns,{min,max,width}];
range=Table[ToString[lower[[n]]]-ToString[upper[[n]]],{n,1,Length[lower]}];
frequencytable=Partition[Append[Riffle[range,counts,2],counts[[groups]]],2]

We can do a quick check with Mathematica  to see if this is correct.  Notice that the value 12 did end up in the correct bin.

BinLists[returns,{min,max,width}]

So lets present a visually appealing table of this grouping.  We list the grouping information in the left column and place the number of individual data elements directly to the right of the grouping.  The result is what is know as a Frequency Table.

fulldata=Prepend[frequencytable,{"Class Limit","Number MF with Return"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]

Lets look at that again:

fulldata=Prepend[frequencytable,{"Class Limit","Number MF with Return"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]

We most likely would present the above table in an article, but if we were going present this to a group of people, we most likely would create a small graph out of this.  The most appropriate graph is called a Frequency Plot.

BarChart[frequencytable[[All,2]],ChartLabels->frequencytable[[All,1]]]

Making this a bit more formal:

BarChart[frequencytable[[All,2]],ChartLabels->{frequencytable[[All,1]]},ChartStyle->"DarkRainbow",PlotLabel->Style["Three Year Returns",18,Blue],AxesLabel->{"%","Number of Stocks"}]

So it is easy to see that more Mutual Funds returned in the "12 - 13.99" group over this three year period.  But say someone asked you to predict what the three year return for another Mutual Fund might have been?

fulldata=Prepend[frequencytable,{"Class Limit","Number MF with Return"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]

Well we could use the above table, but most business professionals prefer to see an additional column added to this table.  The column is called Relative Frequency and it will help you predict the chance that a Mutual Fund would have returned in any data range.

The Relative Frequency column is calculated in two steps.  First, you add up the number of data elements in the data set.

dataelements=Length[returns]

Then you divide the number of specific data elements found in each bin by the total number of data elements in the set.  And Wa-La.

relfrequencytable=Table[{frequencytable[[n,1]],frequencytable[[n,2]],(((frequencytable[[n,2]])/dataelements))},{n,1,Length[frequencytable]}];
fulldata=Prepend[relfrequencytable,{"Class Limit","Number MF with Return","Relative Frequency"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]

This says that there is about a (10/41) chance that a given Mutual Fund had a three year return of 14-15.99%.

Lets look at that table again.  This time with the Relative Frequency stated as a decimal.

relfrequencytable=Table[{frequencytable[[n,1]],frequencytable[[n,2]],N[(((frequencytable[[n,2]])/dataelements))]},{n,1,Length[frequencytable]}];
fulldata=Prepend[relfrequencytable,{"Class Limit","Number MF with Return","Relative Frequency"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]

So now we know the Relative Frequency of each element within the data set.  Now lets put it into a Relative Frequency chart.

BarChart[relfrequencytable[[All,3]],ChartStyle->"DarkRainbow"]

Making this a bit more formal:

BarChart[relfrequencytable[[All,3]],ChartLabels->{relfrequencytable[[All,1]]},ChartStyle->"DarkRainbow",PlotLabel->Style["Three Year Returns",18,Blue],AxesLabel->{"% Returns","Percent of Stocks"}]

But maybe you would like to know what is that probability that a Mutual Fund returned at or below a given level of returns for the three year period.  For this we need to calculate the Cumulative Relative Frequency.

cumfrequencytable=Table[{relfrequencytable[[n,1]],relfrequencytable[[n,2]],N[(((frequencytable[[n,2]])/dataelements))],N[((Sum[N[frequencytable[[i,2]]],{i,1,n}])/dataelements)]},{n,1,Length[relfrequencytable]}];
fulldata=Prepend[cumfrequencytable,{"Class Limit","Number MF with Return","Relative Frequency","Cumulative Relative Frequency"}];
DisplayTable[fulldata,TableLabel->"Three Year Returns",ItemSize->13]
ListPlot[Table[cumfrequencytable[[n,4]],{n,1,groups}],AxesOrigin->{0,0},Joined->True]

But maybe you would like to know what is that probability that a Mutual Fund returned at or below a given level of returns for the three year period.  For this we need to calculate the Cumulative Relative Frequency.

Concept Exploration

Steps

There are five steps to creating a Cumulative Relative Frequency plot.

Tally the elements within each data grouping

Count the elements within the data set

Divide the tally within each bin by the count of elements in the data set

Add cumulative frequencies to the table (sum of relative frequencies at and below data bin)

Chart the result

Examples

Example 1

Lets look at the maximum temperatures for the summer months in Peoria Illinois (in deg C).  Lets create a cumulative relative frequency chart of these temperatures.

hightemps=
Table[WeatherData["Peoria", "MaxTemperature", {{2009, 6, 1}, {2009, 7, 31}, "Day"}]];
temps=Table[hightemps[[n,2]],{n,1,Length[hightemps]}]

1: Tally the elements within each data grouping

min =IntegerPart[Min[temps]]
max=IntegerPart[Max[temps]+1]
groups=8

width=Round[(((IntegerPart[Max[temps]+1]-IntegerPart[Min[temps]]))/groups)]
lower=Table[IntegerPart[Min[temps]]+(n-2),{n,2,(2 groups),width}];
upper=Table[IntegerPart[Min[temps]]+n-.01,{n,2,(2 groups),width}];

counts=BinCounts[temps,{min,max+1,width}];
range=Table[ToString[lower[[n]]]-ToString[upper[[n]]],{n,1,Length[lower]}];
frequencytable=Partition[Append[Riffle[range,counts,2],counts[[groups]]],2]

fulldata=Prepend[frequencytable,{"Max Temp Range","Number Days with Max Temp"}];
DisplayTable[fulldata,TableLabel->"Max Temps Summer 2009",ItemSize->13]

(Labeled[({{"Max Temp Range", "Number Days with Max Temp"}, {"32"-"33.99", 5}, {"34"-"35.99", 7}, {"36"-"37.99", 4}, {"38"-"39.99", 6}, {"40"-"41.99", 10}, {"42"-"43.99", 14}, {"44"-"45.99", 13}, {"46"-"47.99", 2}}), "Max Temps Summer 2009"])

2: Count the elements within the data set

number=Length[temps]

3: Divide the frequency of each data element by the count

reltempfrequency=Table[{frequencytable[[n,1]],frequencytable[[n,2]],N[(((frequencytable[[n,2]])/number)),2]},{n,1,Length[frequencytable]}];
fulldata=Prepend[reltempfrequency,{"Temp Range","Days","Relative Frequency"}];
DisplayTable[fulldata,TableLabel->"Max Temps Summer 2009",ItemSize->13]

(Labeled[({{"Temp Range", "Days", "Relative Frequency"}, {"32"-"33.99", 5, 0.0819672131147540983`2.}, {"34"-"35.99", 7, 0.1147540983606557377`2.}, {"36"-"37.99", 4, 0.0655737704918032787`2.}, {"38"-"39.99", 6, 0.0983606557377049181`2.}, {"40"-"41.99", 10, 0.1639344262295081967`2.}, {"42"-"43.99", 14, 0.2295081967213114754`2.}, {"44"-"45.99", 13, 0.2131147540983606557`2.}, {"46"-"47.99", 2, 0.0327868852459016394`2.}}), "Max Temps Summer 2009"])

4. Add cumulative frequencies to the table (sum of relative frequencies at and below data group)

cumtemptable=Table[{frequencytable[[n,1]],frequencytable[[n,2]],N[(((frequencytable[[n,2]])/number)),2],N[((Sum[N[frequencytable[[i,2]]],{i,1,n}])/number)]},{n,1,Length[frequencytable]}];
fulldata=Prepend[cumtemptable,{"Temp Range","Days","Relative Frequency","Cumulative Relative Frequency"}];
DisplayTable[fulldata,TableLabel->"Max Temps Summer 2009",ItemSize->13]

(Labeled[({{"Temp Range", "Days", "Relative Frequency", "Cumulative Relative Frequency"}, {"32"-"33.99", 5, 0.0819672131147540983`2., 0.0819672131147541`}, {"34"-"35.99", 7, 0.1147540983606557377`2., 0.19672131147540983`}, {"36"-"37.99", 4, 0.0655737704918032787`2., 0.26229508196721313`}, {"38"-"39.99", 6, 0.0983606557377049181`2., 0.36065573770491804`}, {"40"-"41.99", 10, 0.1639344262295081967`2., 0.5245901639344263`}, {"42"-"43.99", 14, 0.2295081967213114754`2., 0.7540983606557378`}, {"44"-"45.99", 13, 0.2131147540983606557`2., 0.9672131147540984`}, {"46"-"47.99", 2, 0.0327868852459016394`2., 1.`}}), "Max Temps Summer 2009"])

5: Chart the result

ListPlot[Table[cumtemptable[[n,4]],{n,1,groups}],AxesOrigin->{0,0},Joined->True]

Example 2

Lets give it a try with a smaller data set.

Your Mathematics teacher graded the last test and determined the following grades:  A,C,D,B,B,A,C,B,C,A,D,B,C,C,C,B,A.     Create a Cumulative Relative Frequency Chart for the grades.

1: Tally the elements within the data set

grades={A,C,D,B,B,A,C,B,C,A,D,B,C,C,C,B,A};
gradefreq=Tally[Sort[grades]]

2: Count the elements within the data set

tests=Length[grades]

3: Divide the frequency of each data element by the count

relgradefrequency=Table[{gradefreq[[n,1]],gradefreq[[n,2]],N[(((gradefreq[[n,2]])/tests)),2]},{n,1,Length[gradefreq]}];
TableForm[Prepend[relgradefrequency,{"Grade Earned","Qty","Relative Frequency"}]]

4: Add cumulative frequencies to the table (sum of relative frequencies at and below data group)

cumgradefrequency=Table[{gradefreq[[n,1]],gradefreq[[n,2]],N[(((gradefreq[[n,2]])/tests)),2],N[((Sum[N[gradefreq[[i,2]]],{i,1,n}])/tests)]},{n,1,Length[gradefreq]}];
TableForm[Prepend[cumgradefrequency,{"Grade Earned","Qty","Relative Frequency","Cumulative Relative Frequency"}]]

5: Chart the result

ListPlot[Table[cumgradefrequency[[n,4]],{n,1,Length[cumgradefrequency]}],AxesOrigin->{0,0},Joined->True]

Example 3

Lets look at an example of the cumulative relative frequency chart that is found at www.demonstrations.wolfram.com.

binIndex[data_,freq_]:=If[data[[1]][[2]]≥ freq,0,1+binIndex[Rest[data],freq]]

monotonicSplineFit[data_,x_Symbol]:=Module[{variables,slack,transposedData,xData,yData,ΔxData,ΔyData,gradientData,objectiveAndConstraints,variableValues,aValues,bValues,cValues,dValues,abscissa},(variables=Map[ToExpression["c"<>ToString[#]]&,Range[Length[data]]];transposedData=Transpose[data];xData=transposedData[[1]];yData=transposedData[[2]];ΔxData=Rest[xData]-Most[xData];ΔyData=Rest[yData]-Most[yData];gradientData=((ΔyData)/(ΔxData));objectiveAndConstraints=Join[{-Apply[Plus,((Drop[variables,2]+2Most[Rest[variables]])/(Most[ΔxData]))+((Drop[variables,-2]+2Most[Rest[variables]])/(Rest[ΔxData]))-slack]},Thread[GreaterEqual[variables,0]],Thread[LessEqual[Most[variables]-Rest[variables],3gradientData]],Thread[LessEqual[-Most[variables]+Rest[variables],3gradientData]],Thread[LessEqual[2Most[variables]+Rest[variables],9gradientData]],Thread[LessEqual[Most[variables]+2Rest[variables],9gradientData]],Thread[LessEqual[((Drop[variables,2]+2Most[Rest[variables]])/(Most[ΔxData]))+((Drop[variables,-2]+2Most[Rest[variables]])/(Rest[ΔxData]))-slack,-((3Most[Rest[yData]]-3Drop[yData,2])/((Most[ΔxData])^2))+((3Most[Rest[yData]]-3Drop[yData,-2])/((Rest[ΔxData])^2))]]];variableValues=variables/.Minimize[objectiveAndConstraints,Append[variables,slack]][[2]];aValues=Most[variableValues]+Rest[variableValues]-2gradientData;bValues=3gradientData-2Most[variableValues]-Rest[variableValues];cValues=Most[variableValues];dValues=Most[yData];abscissa=x-Most[xData];aValues (abscissa^3)+bValues (abscissa^2)+cValues  abscissa+dValues)]

quantileEstimateDiagram[p_,data_]:=Module[{x,msf,func,freq,bi,quantile,transposedData},(transposedData=Transpose[data];msf=monotonicSplineFit[data,x];func=Apply[Which,Flatten[Transpose[{Thread[LessEqual[x,Rest[transposedData[[1]]]]],msf}]]];freq=p*(Last[data][[2]]+1);bi=binIndex[data,freq];quantile=x/.FindRoot[msf[[bi]]==freq,{x,data[[bi]][[1]],data[[bi+1]][[1]]}];Plot[func,{x,First[transposedData[[1]]],Last[transposedData[[1]]]},Epilog->{AbsolutePointSize[5],Map[Point,data],Line[{{0,freq},{quantile,freq},{quantile,0}}]},PlotLabel->Style["percentile = "<>ToString[NumberForm[quantile,{4,3},NumberPadding->{" ","0"}]],"Label",14],ImageSize->{500,300}])]

monotonicSplineFitWithNoise[data_,x_Symbol]:=Module[{cvariables,dvariables,svariables,transposedData,xData,yData,ΔxData,ΔyData,gradientData,objectiveAndConstraints,minoc,cvariableValues,dvariableValues,aValues,bValues,cValues,dValues,abscissa},(cvariables=Map[ToExpression["c"<>ToString[#]]&,Range[Length[data]]];dvariables=Map[ToExpression["d"<>ToString[#]]&,Range[Length[data]]];svariables=Map[ToExpression["s"<>ToString[#]]&,Range[Length[data]]];transposedData=Transpose[data];xData=transposedData[[1]];yData=transposedData[[2]];ΔxData=Rest[xData]-Most[xData];ΔyData=Rest[yData]-Most[yData];gradientData=((ΔyData)/(ΔxData));objectiveAndConstraints=Join[{Apply[Plus,svariables]},Thread[GreaterEqual[svariables,yData-dvariables]],Thread[GreaterEqual[svariables,-yData+dvariables]],Thread[GreaterEqual[cvariables,0]],Thread[LessEqual[Most[cvariables]-Rest[cvariables],3(((Rest[dvariables]-Most[dvariables])/(ΔxData)))]],Thread[LessEqual[-Most[cvariables]+Rest[cvariables],3(((Rest[dvariables]-Most[dvariables])/(ΔxData)))]],Thread[LessEqual[2Most[cvariables]+Rest[cvariables],9(((Rest[dvariables]-Most[dvariables])/(ΔxData)))]],Thread[LessEqual[Most[cvariables]+2Rest[cvariables],9(((Rest[dvariables]-Most[dvariables])/(ΔxData)))]],Thread[Equal[((Drop[cvariables,2]+2Most[Rest[cvariables]])/(Most[ΔxData]))+((Drop[cvariables,-2]+2Most[Rest[cvariables]])/(Rest[ΔxData])),-((3Most[Rest[dvariables]]-3Drop[dvariables,2])/((Most[ΔxData])^2))+((3Most[Rest[dvariables]]-3Drop[dvariables,-2])/((Rest[ΔxData])^2))]]];
minoc=Minimize[objectiveAndConstraints,Join[cvariables,dvariables,svariables]];cvariableValues=cvariables/.minoc[[2]];
dvariableValues=dvariables/.minoc[[2]];aValues=Most[cvariableValues]+Rest[cvariableValues]-2((Rest[dvariableValues]-Most[dvariableValues])/(ΔxData));bValues=3((Rest[dvariableValues]-Most[dvariableValues])/(ΔxData))-2Most[cvariableValues]-Rest[cvariableValues];cValues=Most[cvariableValues];dValues=Most[dvariableValues];abscissa=x-Most[xData];aValues (abscissa^3)+bValues (abscissa^2)+cValues  abscissa+dValues)]

quantileEstimateDiagramWithNoise[p_,data_]:=Module[{x,msf,func,freq,bi,quantile,transposedData},(transposedData=Transpose[data];msf=monotonicSplineFitWithNoise[data,x];func=Apply[Which,Flatten[Transpose[{Thread[LessEqual[x,Rest[transposedData[[1]]]]],msf}]]];freq=p*(Last[data][[2]]+1);bi=binIndex[data,freq];quantile=x/.FindRoot[Piecewise[Transpose[{msf,Thread[LessEqual[x,Rest[transposedData[[1]]]]]}]]==freq,{x,data[[bi]][[1]],data[[bi+1]][[1]]}];Plot[func,{x,First[transposedData[[1]]],Last[transposedData[[1]]]},Epilog->{AbsolutePointSize[5],Map[Point,data],Line[{{0,freq},{quantile,freq},{quantile,0}}]},PlotLabel->Style["percentile = "<>ToString[NumberForm[quantile,{4,3},NumberPadding->{" ","0"}]],"Label",14],ImageSize->{500,300}])]

quantileEstimateDiagram[p_,data_,CutCorners->False]:=quantileEstimateDiagram[p,data]

quantileEstimateDiagram[p_,data_,CutCorners->True]:=quantileEstimateDiagramWithNoise[p,data]

rawData[sr_]:=(SeedRandom[sr]; RandomReal[NormalDistribution[],11]);

upperClassBoundaries={-4,-3,-2,-1,0,1,2,3,4};

cumfreq[boundary_,sr_]:=Length[Select[rawData[sr],#<boundary&]]

data[sr_]:=Map[{#,cumfreq[#,sr]}&,upperClassBoundaries];

Manipulate[quantileEstimateDiagram[p/100,data[sr],CutCorners->cutCorners],
{{p,50,"percentile"},10,90,Appearance->"Labeled"},
{{sr,123,"random seed"},1,12345,1},{{cutCorners,True,"cut corners"},{True,False}},
AutorunSequencing->{1,3},SaveDefinitions->True]

💡  Move the sliders to see how the Cumulative Frequency Chart is effected.