Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Hope this isn't too much of a basic question: I'm looking for some Mathematica functions, but I don't know which ones.

Background

I recently read about a simple technique for reading your body's pulse rate using the camera built into the computer (eg an iSight camera at the top of an iMac). The idea is that you put your finger over the camera in a reasonably well-lit room, record a movie (about 15 - 20 seconds), then analyze the frames for varying light intensities, which somehow indicate your pulse. So far the technique seems to be promising. The code is:

getDataFromList[frames_] := 
  Module[{},
   Mean[Flatten[ImageData[#]]] & /@ 
        (ColorSeparate[#][[1]]  (* red channel is best? *)
    & /@ frames)];

AbsoluteTiming[
      testFrames = CurrentImage[200];
      testData = getDataFromList[testFrames]]

ListLinePlot[testData]

The testData starts off like this:

{0.193808, 0.196383, 0.197617, 0.198657, 0.200555, 0.201459,  
 0.201391, 0.1975, 0.197983, 0.198238, 0.200564, 0.201397, 0.202331,  
 0.20271, 0.199668, 0.196999, 0.197857, 0.19826, 0.199329, 0.200624,  
 0.201472, 0.202583, 0.199393, 0.198472, 0.199569, 0.200466, 0.201441,  
 0.203286, etc. 

When plotted, the data for me and my left forefinger looks like it might be working (or could at least be a vaguely human pulse):

my pulse

The data is probably too large to include here - but some of you might have cameras and fingers too, and could generate something similar? In this plot there looks to be about 24 pulses, and the time from AbsoluteTiming was 16.965258, so my pulse rate was about 84. (So holding my finger up to the screen was hard work, obviously...)

Question

Which Mathematica functions can I use to extract the actual pulse rate from this and similar sets of data?

share|improve this question
    
Surprisingly, it didn't add a comment when I voted as a duplicate... This is the question, for others: Can one find the beat of a tune with Fourier analysis? –  rm -rf Aug 2 '12 at 23:11
    
@R.M I don't know, a question on beat detection of a tune seems like a big overkill for this –  Rojo Aug 2 '12 at 23:29
2  
I suggest to reopen. The other question asked for Fourier, and there are a lot of other possible techniques for doing this (autocorrelation, vanishing derivative, second derivative sign alternating, ...) –  belisarius Aug 3 '12 at 5:23
    
I hadn't thought to look for sound-related questions but you're all right, it's only data after all... –  cormullion Aug 3 '12 at 6:58
1  
@belisarius please show us one now. :-) –  Mr.Wizard Aug 5 '12 at 0:46
show 4 more comments

1 Answer

up vote 17 down vote accepted

Let's invent some data. The pulse rate will be 50

pulseRate = 50;
sampleRate = 1000;
data = Range[0, 1, 1/sampleRate] /. 
 t_ :> Sin[2. Pi pulseRate t] + 8 Sinc[Pi t 2.]^2 // # + 
 RandomReal[0.3 {-1, 1}, Length@#] &;
ListLinePlot[data, DataRange -> {0, 200}, PlotRange -> Full]

Mathematica graphics

Plotting Fourier already shows it will be easy to extract the value

ListLinePlot[Abs@Fourier[data], PlotRange -> {{0, 200}, Full}, 
 DataRange -> {0, sampleRate}]

Mathematica graphics

For whatever reason, let's filter it a little bit first

filteredData = data~MovingAverage~10~DerivativeFilter~{1};
ListLinePlot[filteredData]

Mathematica graphics

Now we see more cleary that the peaks are in the pulse rate

ListLinePlot[Abs@Fourier[filteredData], 
 PlotRange -> {{0, 200}, Full}, DataRange -> {0, sampleRate}]

Mathematica graphics

In a general case we could be more careful finding the peaks but, let's just find the 2 maximums and their corresponding frequency

(Ordering[Abs@Fourier[filteredData], -2] - 1) Length@data/sampleRate // N

{50.05, 942.942}

Abs@Mod[%, 1000, -500]

{50.05, 57.058}

It's a start

Another quick approach

This would give an indicator vector with ones where there's a peak (local maximum or minimum)

peaks = Unitize@Differences@Sign@Differences[data~MovingAverage~10];

This would give the number of samples between peaks

peakIntersamples = Differences@Flatten@Position[peaks, 1];

From that we can estimate the pulse rate

sampleRate/Median@peakIntersamples/2

50

share|improve this answer
    
Nice answer - many thanks for this, rojo. I'd upvote and accept if the question hadn't been closed :/ –  cormullion Aug 3 '12 at 7:00
    
@cormullion it has now been unclosed :). But even if you feel like accepting, have an open mind about changing the accept in the future: I have the feeling a couple of good answers may be coming now it has been reopen ;D –  Rojo Aug 3 '12 at 11:06
1  
data~MovingAverage~10~DerivativeFilter~{1} ... damn –  belisarius Aug 4 '12 at 20:39
    
@belisarius infix fits those kind of functions perfectly, right? :) –  Rojo Aug 4 '12 at 23:52
    
@rojo Your answer was obviously the last word in the subject! Thanks - it was very helpful. –  cormullion Aug 11 '12 at 7:52
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.