Reverse Conducting Evaluation
Craig Stuart Sapp <craig@ccrma.stanford.edu>
15 Nov 2005

This is a generic Mathematica notebook used for examining the individual reverse conducting performances of Chopin Mazurkas compared to carefully corrected versions of the average beat tappings for the performance.

Mazurka in A Minor, Op. 7, No. 2
Chiu 1999

Loading the raw data

First load the absolute beat positions for the average beat positions and the corrected beat positions:

performance  =  "pid9048-06";
pvar  =  
        StringReplace[
          performance,  "-"  ->  "x"];

Get[performance   <>  ".macorrected",  
      Path -> "D:\mazurkas\eval"]
mcbeats  =  
        ToExpression[pvar  <>  "corrected"];

Get[performance  <>  ".maaverage",  
      Path -> "D:\mazurkas\eval"]
mabeats  =  ToExpression[pvar  <>  "average"];

Now measure the time difference between each average and corrected beat.  A negative value means that the average beat occurs before the corrected beat time.

mdiffs  =  Transpose[mabeats][[2]]  -  Transpose[
            mcbeats][[2]]

The average correction to each beat from the average tap times of all trials is typically around 48 milliseconds.  This means that, on the average, each average tap beat position must be moved 48 milliseconds to align with the correct beat time.

<<  Statistics`ConfidenceIntervals`

Mean[Abs[mdiffs]]  //  N

Manual correction of average reverse conducting beat positions

This section displays the difference between the average reverse conducted beat positions and the values derived from manually correcting these values by ear using an soundfile editor.

This corrected beat duration data was measured by listening to the audio file and manually locating the beat positions in the soundfile.  The initial positions of the average reverse conducting performance were used as a baseline, and this baseline was then adjusted so that it sounded as if all beats were occuring with the attacks of notes in the performance.  There are probably a few errors in the corrected due to the tediousness of getting this data, and there are a few locations in the audio where the beat positions become vague, but overall, this data represents a highly accurate description of the pianists' actual beat-by-beat performance tempo, probably an accuracy within 10 millseconds for all beats.

corrected  =  Transpose[mcbeats][[2]]

avgtimes  =  Transpose[mabeats][[2]];

Here are the timing differences between the average reverse-conducting absolute times and the absolute times measured in a sound editor:

diffs  =  corrected  -  avgtimes;

ListPlot[diffs,  Frame -> True,  AspectRatio -> 1/4,  
        PlotStyle -> PointSize[0.008]];

The average beats are not quite centered on the corrected beats.  The average beats are, on the average, 4.6 milliseconds after the corrected beats.

offseterror  =  Mean[diffs]  //  N

The histogram below shows the data from the plot above.  It generally shows a nicely distributed range of corrections.  The peak at 0 is due to the correction values being too small to change to the theoretically correct values about up to 10 milliseconds before their measured positions.

<< Graphics`Graphics`

Histogram[diffs,  AspectRatio -> 1/4,  Frame -> True,  
        BarEdges -> False, HistogramCategories -> 50, 
        HistogramScale -> 100, 
        HistogramRange -> {-200,  200}];

Trial Quality Measurements

Define a logarithmic score for the amount of correction needed for a given beat.  A score of 1 means 20 ms correction, 2 means 40 ms correction, 3 means 80 ms correction, 4, means 160 ms correction, 5 means 360 ms correction, etc. A score of 0 means there was less than 1 millisecond correction necessary, and a score of 0.5 means 10 milliseconds were needed to correct the beat location.

Qualitatively, a score of 0-1 is an "A", 1-2 is a "B", 2-3 is a "C", 3-4 is a "D", 4-5 is an "E", and 5-6 is an "F".  A score of 6 means the correction was 640 milliseconds, or about
2/3 of a second.

QScore[seq_]  :=  
      Module[ {sign,  scores}, 
   sign  =  
          Map[If[# < 0,  -1,  If[# > 0,  1,  0]] &,  
            seq ]; 
scores  =  
          Log[2.0,  Abs[seq] / 10]  /.  -Infinity  ->  
              0; 
scores  =  
          Map[If[#  < 1,  (# + 1)/2.0 ,  #] &,  
            scores]; 
scores  =  
          Map[If[# <  0,  0,  #] &,  
            scores]; 
scores  * 
          sign
]

Mostly the corrections for the average of the tapping trials are evenly distributed between A, B, C, and D quality, although "A" corrections were the most common.  The worst case correction was between a value of 4 and 5.  This occurs on the first beat when there has been no preparation of a previous event, so is most likely due to the reaction time of the reverse conductor.  Other corrections in the range between 4 and 5 are also likely due to an unprepared change in tempo which was not expected beforehand.

<< Graphics`Graphics`

Histogram[Abs[QScore[mdiffs]],  
        AspectRatio -> 1/4,  
HistogramScale -> 
          100, Frame -> True,  
        HistogramCategories -> 5];

The range from 0-1 can be characterized as "no audible difference"(0-20 ms); 1-2 as "slight audible difference (20-40 ms); 2-3 "minor audible difference (40-80 ms); 3-4 as "noticeable audible difference" (80-160 ms), 4-5 as "very noticeable audible difference" (160-320 ms), and anythhing higher as "extremely noticeable audible difference" (> 320 ms).

Mean[Abs[QScore[mdiffs]]]

Here is a histogram display of the necessary corrections with positive and negative adjustments separated.  Negative values mean that the correct value occurs before the average reverse conduting time.  Notice that most of the larger corrections occur in the negative range

Histogram[QScore[mdiffs],  AspectRatio -> 1/4,  
        HistogramScale -> 100,  Frame -> True,  
        HistogramCategories -> 11];

Examine the learning curve

How does the quality of the reverse conducting improve over time? Does the conductor learn to follow the performance better after repeated listening?  First, load the individual tapping trials which contain precalculated offset values into the audio file of the performance recording:

Get[performance  <>  "-abs.ma",  
      Path -> "D:\mazurkas\eval"]
data  =  ToExpression[pvar  <>  "abs"];

Now calculate the timing differences between the individual trials and the corrected beat times.

trialdiffs  =  
        Transpose[
          Transpose[
              data]  -  Transpose[mcbeats][[2]]];

Map[Mean[Abs[QScore[#]]] &,  trialdiffs]

Here are quality score plots for each trial:

Table[
        Histogram[Abs[QScore[trialdiffs[[xz]]]],  
          AspectRatio -> 1/4,  Frame -> True,  
          Range -> {{0, 6} {0, 30}},  HistogramScale -> 100,  
          HistogramCategories -> 5],  {xz,  1,  
          Length[trialdiffs]}];

How does the accuracy of the first half of the trials compare to the second half of the trials?:

firsttrials  =  
        Drop[trialdiffs,  -10];
lasttrials  =  Drop[trialdiffs,  10];
avgfirst  =  
        Map[Mean, Transpose[firsttrials]];
avglast  =  Map[Mean,  Transpose[lasttrials]];

Histogram[Abs[QScore[avgfirst]],  
        AspectRatio -> 1/4,  
HistogramScale -> 
          100, Frame -> True,  
        HistogramCategories -> 5];

Histogram[Abs[QScore[avglast]],  
        AspectRatio -> 1/4,  
HistogramScale -> 
          100, Frame -> True,  
        HistogramCategories -> 5];

Mean[Abs[QScore[avgfirst]]]

Mean[Abs[QScore[avglast]]]

On the average, beats in the second half of the trials are 6 milliseconds closer to the "true" beat locations:

firsterr  =  Mean[Abs[avgfirst]]

lasterr   =  Mean[Abs[avglast]]

firsterr  -  lasterr

allerr  =  N[Mean[Abs[mdiffs]]]

allerr -  lasterr

Plotting the average displacement error for each trial

This section plots the average displacement error for each trial which shows the gradual improvement in the reverse conducting over time.

avgerr  =  
      Table[Apply[Plus,  
              Sqrt[ trialdiffs[[i]] * trialdiffs[[i]] ] ] / 
            Length[trialdiffs[[i]]] * 1.0  ,  {i,  1,  
          Length[trialdiffs]}]

errplot  =  
        ListPlot[avgerr,  PlotJoined -> True,  Frame -> True,  
          AspectRatio -> 1/3];

Now fit an exponentially decreasing line though the trial errors to model what the "learning curve" is for reverse conducting this performance.

logfit  =  Fit[Log[10,  avgerr],  {1,  x},  x]

fitplot  =  
        Plot[10^logfit, { x,  0,  20},  
          PlotStyle -> Hue[0]];

Show[errplot,  fitplot,  errplot];

Predictions of accuracy can be derived from the learning curve over time:

err40  =  10^logfit  /.  x ->  40

lasterr  -  err40

err100  =  10^logfit  /.  x ->  100

lasterr  -  err100

Effect of removing the "worst" trial

What happens if the "worst" trial  is removed from the average tapping time for each beat?

maxindex  =  1;
For[i = 1,  
        i < Length[avgerr],  i++, 
  If[
            avgerr[[maxindex]]  <  avgerr[[i]],  
            maxindex  =  
              i];
];
maxindex  =  maxindex

newerrset  =  
        RotateRight[Drop[RotateLeft[trialdiffs,  maxindex],  -1],  
          maxindex - 1];

newavgerr  =  
      Table[Apply[Plus,  
              Sqrt[ newerrset[[i]] * newerrset[[i]] ] ] / 
            Length[newerrset[[i]]] * 1.0  ,  {i,  1,  
          Length[newerrset]}]

newplot  =  
        ListPlot[newavgerr,  PlotJoined -> True,  
          Frame -> True,  AspectRatio -> 1/3];

logfit  =  Fit[Log[10,  newavgerr],  {1,  x},  x]

newfitplot  =  
        Plot[10^logfit, { x,  0,  20},  
          PlotStyle -> Hue[0]];

Show[newplot,  newfitplot,  newplot];

newavg  =  Mean[Abs[Map[Mean,  Transpose[newerrset]]]]

allerr

Trying to identifying "worst" performances from the average

Instead of comparing the individual performances to the corrected data, compare them to the average of all trials.

avgtrialdiffs  =  
        Transpose[
          Transpose[
              data]  -  Transpose[mabeats][[2]]];

errfromavg =  Map[Mean, Abs[avgtrialdiffs]]  // N

errminusone  =  
        ListPlot[errfromavg, PlotJoined -> True,  Frame -> True, 
          PlotRange -> All,  Axes -> False,  
          AspectRatio -> 1/3];

Dropping any single trial

Dropping the worst trial does not improve the accuracy of the average. Does dropping any other trial improve the average of all trials?

droppedsets  =  
        Table[RotateRight[Drop[RotateLeft[trialdiffs,  i],  -1],  
            i],  {i,  1,  20}];

droppedavg  =  
      Table[Mean[
          Abs[Map[Mean,  Transpose[droppedsets[[i]] ]]]],  {i,  1,  
          20}]

plot  =  
        ListPlot[droppedavg,  PlotJoined -> True,  
          Frame -> True,  Axes -> False,  
          DisplayFunction -> Identity];

Show[plot,  
        Graphics[{RGBColor[0, 1, 0], 
            Line[{{0,  allerr},  {20,  allerr}}]}], 
        DisplayFunction -> $DisplayFunction,  
        AspectRatio -> 1/3];

Dropping a range of trials

Now examine how the displacement error changes as more and more of the earlier trials are removed from the average.

dsets  =  
        Table[Drop[trialdiffs,  i],  {i,  1,  19}];

davg  =  
      Table[Mean[Abs[Map[Mean,  Transpose[dsets[[i]] ]]]],  {i,  1,  
          19}]

dplot  =  
        ListPlot[davg,  PlotJoined -> True,  Frame -> True,  
          Axes -> False,  
          DisplayFunction -> Identity];

dplotp  =  
        ListPlot[davg,  PlotStyle -> PointSize[0.02],  
          Frame -> True,  Axes -> False,  
          DisplayFunction -> Identity];

dropstart  =  
        Show[dplot,  dplotp,  
          Graphics[{RGBColor[0, 1, 0], 
              Line[{{1,  allerr},  {19,  allerr}}]}], 
          FrameTicks -> {Range[19],  Automatic,  None,  None},  
          DisplayFunction -> $DisplayFunction,  
          PlotRange -> All,  AspectRatio -> 1/3];

Here is a plot created by dropping the later trials more and more:

rdsets  =  
        Table[Drop[trialdiffs,  -i],  {i,  1,  19}];

rdavg  =  
      Table[Mean[Abs[Map[Mean,  Transpose[rdsets[[i]] ]]]],  {i,  
          1,  19}]

rdplotp  =  
        ListPlot[rdavg,  
          PlotStyle -> {RGBColor[0, 0, 1], PointSize[0.02]},  
          Frame -> True,  Axes -> False,  
          DisplayFunction -> Identity];

rdplot  =  
        ListPlot[rdavg,  PlotJoined -> True,  Frame -> True,  
          Axes -> False,  DisplayFunction -> Identity,  
          PlotStyle -> RGBColor[0, 0, 1]];

dropend  =  
        Show[rdplot,  
          rdplotp,   Graphics[{RGBColor[0, 1, 0], 
              Line[{{1,  allerr},  {19,  allerr}}]}], 
          FrameTicks -> {Range[19],  Automatic,  None,  None},  
          DisplayFunction -> $DisplayFunction,  
          PlotRange -> All,  AspectRatio -> 1/3];

Show[dropstart,  dropend];

individ  =  
      Map[Mean[N[Abs[#  -  Transpose[mcbeats][[2]]]]] &,  
        data]

individplot  =  
        ListPlot[individ,  PlotStyle -> {Hue[0.0], PointSize[0.02]},  
          Frame -> True,  Axes -> False,  
          DisplayFunction -> Identity,  
          AspectRatio -> 1/3];

individplotp  =  
        ListPlot[individ,  PlotJoined -> True,  Frame -> True,  
          Axes -> False,  PlotStyle -> Hue[0.0], 
          DisplayFunction -> Identity];

Show[individplot,  individplotp,  
        DisplayFunction -> $DisplayFunction];

Show[individplot,  individplotp,  dropstart,  dropend,  
        DisplayFunction -> $DisplayFunction];

The red curve in the plot above shows the average displacement errors from the corrected times for each of the 20 individual trials.  The blue curve represents dropping more and more of the later trials being dropped.  The black curve represents dropping more and more of the earlier trials.

Offset sensitivity

Individual trials were aligned to the  test case using a few points which seemed to be in a stable tempo region. How accurate is the offset calculated from these few points in the audio?  Would the average of all trials improve if an offset is calculated for each trial based on the corrected data?

SquareDiff[x_,  y_]  :=  
      Apply[Plus,  (x  -  y) * (x  -  y)]

AlignSequences[seq1_,  seq2_]  :=  
      Module[
{diffs}, 
diffs  =  
          Table[{x,  
              SquareDiff[seq1,  seq2  +  x]},  {x,  -10000,  
              10000,  100}]; 
(x  /.  
              Solve[D[Fit[diffs,  {1,  x,  x^2},  x],  x]  ==  
                  0,  x])[[1]]
]

AlignSequences[{1, 2, 3}, {2, 3, 4}]

addoffsets  =  
      Table[ AlignSequences[Transpose[mcbeats][[2]],  
          data[[i]]],  {i,  1,  Length[data]}]

newmabeats   =  
        Map[Mean,  Transpose[data  + addoffsets]];

extraoffset  =  Mean[addoffsets]

Min[addoffsets]
Max[addoffsets]

omdiffs  =  Transpose[mcbeats][[2]]  -  
          newmabeats;

N[Mean[Abs[omdiffs]]]

Comparing corrected beats to average reverse conducting beats

This section plots the average tempo range and compares it to the acutal tempos measured from the audio file.

Get[performance  <>  ".ma",  
      Path -> "D:\mazurkas\eval"]
data  =  Transpose[ToExpression[pvar]];

eachbeatstats  =  
        Map[DispersionReport,  data]  //  N;

confidence  =  
        Map[MeanCI[#[[1]],  
              KnownStandardDeviation -> (KnownStandardDeviation  /.  #[[2]])] &,  Transpose[{data,  eachbeatstats}]];

durationmean  =  
        Map[ Mean,  data]  //  N;
maxdurs  =  Map[Max,  data];
mindurs  =  Map[Min,  data];

meanhighplot  =  
        ListPlot[Transpose[confidence][[1]],  
          PlotJoined -> True,  DisplayFunction -> Identity,  
          PlotStyle -> 
            RGBColor[ .5,  .5,  .5]];
meanlowplot  =  
        ListPlot[Transpose[confidence][[2]],  
          PlotJoined -> True,  DisplayFunction -> Identity,  
          PlotStyle -> 
            RGBColor[ .5,  .5,  .5]];
maxplot  =  
      ListPlot[maxdurs,  DisplayFunction -> Identity,  
        PlotJoined -> True,  
        PlotStyle -> RGBColor[0.8, 0.8, 0.8]]; 
    minplot  =  
      ListPlot[mindurs,  DisplayFunction -> Identity,  
        PlotJoined -> True,  
        PlotStyle -> RGBColor[0.8, 0.8, 0.8]];

\(\(\(\ \)\(meanplot\  = \ 
        ListPlot[durationmean, \ PlotJoined -> True, \ 
          PlotRange -> All, \ AspectRatio -> 1/3, \ 
          Frame -> 
            True, 
FrameLabel -> {"beats", "milliseconds", \ "measures", "tempo"}, \ \ FrameTicks -> {Automatic, \ Automatic, \ Table[{x, x/3}, {x, 0, 315, 3}]\ , \ 
              Map[{60000.0\ /\ #, \ #} &, \ {30, 40, 44, 48, 54, 60, 70, 82, 
                  100, 128, 180, \ 280}]}];\)\)\)

allplot  =  
        Show[meanplot,  maxplot,  minplot,  meanhighplot,  meanlowplot,  
          meanplot,  Axes -> False];

correctdeltas  =  
        Drop[RotateLeft[corrected,  1]  -  
            corrected,  -1];

cordels   =  
        Transpose[ 
          Partition[
            Transpose[{Drop[ Transpose[mcbeats][[1]]  +  
                    1,  -1],  correctdeltas}],  3]];

correctplot  =  
        Show[Graphics[{PointSize[0.02],  RGBColor[1, 0, 0],  
              Map[Point,  cordels[[1]]],  RGBColor[0, 0, 1],  
              Map[Point,  cordels[[2]]],  
              Map[Point, cordels[[3]]]}],  
          AspectRatio -> 1/4];

newallplot  =  Show[allplot, correctplot];

finalplot  =  
        Show[allplot,  correctplot,  allplot,  Frame -> True,  
          PlotRange -> {{0,  20}, {350,  900}},  
          FrameTicks -> {Range[20],  Automatic,  Automatic,  
              None}];

\(ShowFrame[finalplot_, \ minrange_, \ maxrange_, \ len_, \ frame_, \ 
        width_]\  := \ 
      Module[
{framecount, \ startpoint, \ endpoint, 
          rmin, \ rmax, \ starti, \ endi, \ 
          delta}, 
framecount\  = \ 
          len\ /\ width\ \  + \ 0.99\  // \ 
            Floor; 
startpoint\  = \ 
          frame\ *\ width\  + \ 
            1; 
endpoint\  = \ \ \((frame + 1)\)\ *\ 
              width\  + \ 
            1; 
starti\  = \ \((startpoint\  - \ 
                1)\)\ \  + \ 
            1; 
endi\  = \ \((endpoint\  - \ 1)\)\  + \ 
            1; 
If[endi\  > \ len, \ 
          endi\  = \ len]; 
If[starti\  > \ len, \ 
          starti\  = \ len]; 
rmax\  = \ 
          Max[Take[
              maxrange, \ {starti, \ 
                endi}]]; 
delta\ \  = \ 
          rmax\ *\ 0.03; 
rmax\  = \ 
          rmax\  + \ delta; 
rmax\  = \ 
          1500; 
rmin\  = \ 
          Min[\ Take[
              minrange, \ {starti, \ endi\ }]]; 
rmin\  = \ 
          rmin\  - \ delta; 
rmin\  = \ 
          200; 
Show[finalplot, \ 
          PlotRange -> {{startpoint, \ endpoint}, \ {rmin, \ 
                rmax}}, 
FrameLabel -> {"beats", "milliseconds", \ "measures", "tempo"}, \ \ FrameTicks -> {Automatic, \ Automatic, \ Table[{x + 1, x/3 + 1}, {x, 0, 2000, 3}]\ , \ 
              Map[{60000.0\ /\ #, \ #} &, \ {30, 40, 44, 48, 54, 60, 70, 82, 
                  100, 128, 180, \ 280}]}, 
Axes -> 
            False]
]\)

Here is a zoom in on the tempo for every 8 measures.  The black line indicates the mean reverse-conducted durations for every beat.  The dark gray lines surrounding the average duration line is the 95% confidence range for the true mean, and the light gray lines indicate the maximum and minumum durations for each beat from all reverse conducting trials.

The red and blue dots indicates the beat event durations from the audio file which are more accurate than the average reverse conducting durations, and can be assumbed to be the "correct" answer.  The red dots represent the first beat of a measure, and the blue dots represent the other beats in the measure.

Table[
        ShowFrame[newallplot,  mindurs,  maxdurs,  Length[data], i,  
          24],  {i,  0,  
          Floor[ Length[data]/8.0/3.0 +  .99 ]  -  1}];