Bagaimana menemukan puncak / lembah lokal dalam serangkaian data?


16

Ini eksperimen saya:

Saya menggunakan findPeaksfungsi dalam paket kuantmod :

Saya ingin mendeteksi puncak "lokal" dalam toleransi 5, yaitu lokasi pertama setelah rangkaian waktu turun dari puncak lokal sebanyak 5:

aa=100:1
bb=sin(aa/3)
cc=aa*bb
plot(cc, type="l")
p=findPeaks(cc, 5)
points(p, cc[p])
p

Outputnya adalah

[1] 3 22 41

Tampaknya salah, karena saya mengharapkan lebih banyak "puncak lokal" dari 3 ...

Adakah pikiran?


Saya tidak punya paket ini. Bisakah Anda menggambarkan rutin numerik yang digunakan?
AdamO

Kode sumber lengkap untuk findPeaksmuncul di balasan saya, @Adam. BTW, paketnya adalah "quantmod" .
Whuber

Cross diposting di R-SIG-Finance .
Joshua Ulrich

Jawaban:


8

Sumber kode ini diperoleh dengan mengetik namanya di prompt R. Outputnya adalah

function (x, thresh = 0) 
{
    pks <- which(diff(sign(diff(x, na.pad = FALSE)), na.pad = FALSE) < 0) + 2
    if (!missing(thresh)) {
        pks[x[pks - 1] - x[pks] > thresh]
    }
    else pks
}

Tes ini x[pks - 1] - x[pks] > threshmembandingkan setiap nilai puncak dengan nilai yang langsung berhasil dalam seri (bukan ke palung berikutnya dalam seri). Ini menggunakan perkiraan (kasar) dari ukuran kemiringan fungsi segera setelah puncak dan memilih hanya puncak-puncak di mana kemiringan melebihi threshukuran. Dalam kasus Anda, hanya tiga puncak pertama yang cukup tajam untuk lulus tes. Anda akan mendeteksi semua puncak dengan menggunakan default:

> findPeaks(cc)
[1]  3 22 41 59 78 96

30

Saya setuju dengan respons whuber tetapi hanya ingin menambahkan bahwa bagian "+2" dari kode, yang berupaya menggeser indeks agar sesuai dengan puncak yang baru ditemukan sebenarnya 'melampaui batas' dan seharusnya "+1". misalnya dalam contoh yang kita dapatkan:

> findPeaks(cc)
[1]  3 22 41 59 78 96

ketika kami menyorot puncak-puncak yang ditemukan ini pada grafik (tebal merah): masukkan deskripsi gambar di sini

kita melihat bahwa mereka secara konsisten 1 poin dari puncak yang sebenarnya.

akibatnya

pks[x[pks - 1] - x[pks] > thresh]

seharusnya pks[x[pks] - x[pks + 1] > thresh]ataupks[x[pks] - x[pks - 1] > thresh]

PEMBARUAN BESAR

mengikuti pencarian saya sendiri untuk menemukan fungsi pencarian puncak yang memadai saya menulis ini:

find_peaks <- function (x, m = 3){
    shape <- diff(sign(diff(x, na.pad = FALSE)))
    pks <- sapply(which(shape < 0), FUN = function(i){
       z <- i - m + 1
       z <- ifelse(z > 0, z, 1)
       w <- i + m + 1
       w <- ifelse(w < length(x), w, length(x))
       if(all(x[c(z : i, (i + 2) : w)] <= x[i + 1])) return(i + 1) else return(numeric(0))
    })
     pks <- unlist(pks)
     pks
}

'puncak' didefinisikan sebagai maksimum lokal dengan mpoin di kedua sisi lebih kecil dari itu. karenanya, semakin besar parameter m, semakin ketat prosedur pendanaan puncak. begitu:

find_peaks(cc, m = 1)
[1]  2 21 40 58 77 95

fungsi ini juga dapat digunakan untuk menemukan minimum lokal dari setiap vektor berurutan xviafind_peaks(-x) .

Catatan: saya sekarang telah meletakkan fungsi pada gitHub jika ada yang membutuhkannya: https://github.com/stas-g/findPeaks


6

Eek: Pembaruan kecil. Saya harus mengubah dua baris kode, batas-batas, (tambahkan -1 dan +1) untuk mencapai kesetaraan dengan fungsi Stas_G (menemukan beberapa 'puncak ekstra' terlalu banyak dalam kumpulan data nyata). Permintaan maaf untuk siapa pun yang tersesat sangat kecil oleh posting asli saya.

Saya telah menggunakan algoritma menemukan puncak Stas_g untuk beberapa waktu sekarang. Itu bermanfaat bagi saya untuk salah satu proyek saya selanjutnya karena kesederhanaannya. Namun saya perlu menggunakannya jutaan kali untuk perhitungan, jadi saya menulis ulang di Rcpp (Lihat paket Rcpp). Ini kira-kira 6x lebih cepat dari versi R dalam tes sederhana. Jika ada yang tertarik, saya telah menambahkan kode di bawah ini. Semoga saya membantu seseorang, Ceria!

Beberapa peringatan kecil. Fungsi ini mengembalikan indeks puncak dalam urutan terbalik dari kode R. Ini membutuhkan inhouse C ++ Sign function, yang saya sertakan. Itu belum sepenuhnya dioptimalkan tetapi keuntungan kinerja lebih lanjut tidak diharapkan.

//This function returns the sign of a given real valued double.
// [[Rcpp::export]]
double signDblCPP (double x){
  double ret = 0;
  if(x > 0){ret = 1;}
  if(x < 0){ret = -1;}
  return(ret);
}

//Tested to be 6x faster(37 us vs 207 us). This operation is done from 200x per layer
//Original R function by Stas_G
// [[Rcpp::export]]
NumericVector findPeaksCPP( NumericVector vY, int m = 3) {
  int sze = vY.size();
  int i = 0;//generic iterator
  int q = 0;//second generic iterator

  int lb = 0;//left bound
  int rb = 0;//right bound

  bool isGreatest = true;//flag to state whether current index is greatest known value

  NumericVector ret(1);
  int pksFound = 0;

  for(i = 0; i < (sze-2); ++i){
    //Find all regions with negative laplacian between neighbors
    //following expression is identical to diff(sign(diff(xV, na.pad = FALSE)))
    if(signDblCPP( vY(i + 2)  - vY( i + 1 ) ) - signDblCPP( vY( i + 1 )  - vY( i ) ) < 0){
      //Now assess all regions with negative laplacian between neighbors...
      lb = i - m - 1;// define left bound of vector
      if(lb < 0){lb = 0;}//ensure our neighbor comparison is bounded by vector length
      rb = i + m + 1;// define right bound of vector
      if(rb >= (sze-2)){rb = (sze-3);}//ensure our neighbor comparison is bounded by vector length
      //Scan through loop and ensure that the neighbors are smaller in magnitude
      for(q = lb; q < rb; ++q){
        if(vY(q) > vY(i+1)){ isGreatest = false; }
      }

      //We have found a peak by our criterion
      if(isGreatest){
        if(pksFound > 0){//Check vector size.
         ret.insert( 0, double(i + 2) );
       }else{
         ret(0) = double(i + 2);
        }
        pksFound = pksFound + 1;
      }else{ // we did not find a peak, reset location is peak max flag.
        isGreatest = true;
      }//End if found peak
    }//End if laplace condition
  }//End loop
  return(ret);
}//End Fn

Ini untuk loop tampaknya cacat, @caseyk: for(q = lb; q < rb; ++q){ if(vY(q) > vY(i+1)){ isGreatest = false; } }sebagai run terakhir melalui loop "menang", melakukan setara dengan: isGreatest = vY(rb-1) <= vY(rb). Untuk mencapai apa yang diklaim oleh komentar di atas garis tersebut, loop untuk perlu diubah menjadi:for(q = lb; isGreatest && (q < rb); ++q){ isGreatest = (vY(q) <= vY(i+1)) }
Bernhard Wagner

Hmmm. Sudah lama sekali sejak saya menulis kode ini. IIRC itu diuji langsung dengan fungsi Stas_G dan mempertahankan hasil yang sama persis. Meskipun saya melihat apa yang Anda katakan, saya tidak yakin apa perbedaan dalam output yang akan dilakukan. Akan layak posting bagi Anda untuk menyelidiki solusi Anda vs yang saya usulkan / diadaptasi.
caseyk

Saya juga harus menambahkan bahwa saya secara pribadi menguji skrip ini mungkin dalam urutan 100x (dengan asumsi ini adalah yang ada di proyek saya) dan itu digunakan lebih dari satu juta kali dan menawarkan hasil tidak langsung yang sesuai dengan hasil literatur untuk kasus uji khusus. Jadi, jika itu 'cacat' itu bukan yang 'cacat';)
caseyk

1

Pertama: Algoritme juga secara salah memanggil setetes ke kanan dataran datar karena sign(diff(x, na.pad = FALSE)) akan menjadi 0 lalu -1 sehingga diffnya juga akan -1. Perbaikan sederhana adalah untuk memastikan bahwa sign-diff sebelum entri negatif bukanlah nol tetapi positif:

    n <- length(x)
    dx.1 <- sign(diff(x, na.pad = FALSE))
    pks <- which(diff(dx.1, na.pad = FALSE) < 0 & dx.1[-(n-1)] > 0) + 1

Kedua: Algoritme memberikan hasil yang sangat lokal, misalnya 'naik' diikuti oleh 'turun' dalam menjalankan tiga istilah berturut-turut dalam urutan. Jika seseorang lebih tertarik pada maxima lokal dari fungsi berkesinambungan yang berisik, maka - mungkin ada hal-hal lain yang lebih baik di luar sana, tetapi ini adalah solusi saya yang murah dan langsung

  1. mengidentifikasi puncak pertama menggunakan rata-rata berjalan 3 poin berturut-turut untuk
    memuluskan data yang sedikit. Juga gunakan kontrol yang disebutkan di atas terhadap flat kemudian drop-off.
  2. saring kandidat ini dengan membandingkan, untuk versi loess-smoothed, rata-rata di dalam jendela berpusat di setiap puncak dengan rata-rata istilah lokal di luar.

    "myfindPeaks" <- 
    function (x, thresh=0.05, span=0.25, lspan=0.05, noisey=TRUE)
    {
      n <- length(x)
      y <- x
      mu.y.loc <- y
      if(noisey)
      {
        mu.y.loc <- (x[1:(n-2)] + x[2:(n-1)] + x[3:n])/3
        mu.y.loc <- c(mu.y.loc[1], mu.y.loc, mu.y.loc[n-2])
      }
      y.loess <- loess(x~I(1:n), span=span)
      y <- y.loess[[2]]
      sig.y <- var(y.loess$resid, na.rm=TRUE)^0.5
      DX.1 <- sign(diff(mu.y.loc, na.pad = FALSE))
      pks <- which(diff(DX.1, na.pad = FALSE) < 0 & DX.1[-(n-1)] > 0) + 1
      out <- pks
      if(noisey)
      {
        n.w <- floor(lspan*n/2)
        out <- NULL
        for(pk in pks)
        {
          inner <- (pk-n.w):(pk+n.w)
          outer <- c((pk-2*n.w):(pk-n.w),(pk+2*n.w):(pk+n.w))
          mu.y.outer <- mean(y[outer])
          if(!is.na(mu.y.outer)) 
            if (mean(y[inner])-mu.y.outer > thresh*sig.y) out <- c(out, pk)
        }
      }
      out
    }

0

Memang benar fungsinya juga mengidentifikasi akhir dari plateaux, tapi saya pikir ada perbaikan lain yang lebih mudah: Karena perbedaan pertama dari puncak nyata akan menghasilkan '1' lalu '-1', perbedaan kedua adalah '-2', dan kita bisa cek langsung

    pks <- which(diff(sign(diff(x, na.pad = FALSE)), na.pad = FALSE) < 1) + 1

Ini sepertinya tidak menjawab pertanyaan.
Michael R. Chernick

0

menggunakan Numpy

ser = np.random.randint(-40, 40, 100) # 100 points
peak = np.where(np.diff(ser) < 0)[0]

atau

double_difference = np.diff(np.sign(np.diff(ser)))
peak = np.where(double_difference == -2)[0]

menggunakan Panda

ser = pd.Series(np.random.randint(2, 5, 100))
peak_df = ser[(ser.shift(1) < ser) & (ser.shift(-1) < ser)]
peak = peak_df.index
Dengan menggunakan situs kami, Anda mengakui telah membaca dan memahami Kebijakan Cookie dan Kebijakan Privasi kami.
Licensed under cc by-sa 3.0 with attribution required.