一連のデータで局所的なピーク/谷を見つける方法は?


16

これが私の実験です。

quantmodパッケージのfindPeaks関数を使用してます:

許容範囲5内の「ローカル」ピーク、つまり、時系列がローカルピークから5低下した後の最初の位置を検出したい:

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

出力は

[1] 3 22 41

私は3つよりも多くの「局所的なピーク」を期待しているので、間違っているようです...

何かご意見は?


私はこのパッケージを持っていません。使用されている数値ルーチンを説明できますか?
AdamO

の完全なソースコードfindPeaksは、返信@Adamに記載されています。ところで、パッケージは"quantmod"です。
whuber

R-SIG-Financeにクロス投稿しました。
ジョシュアウルリッヒ

回答:


8

このコードのソースは、Rプロンプトで名前を入力することにより取得されます。出力は

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
}

このテストでは、x[pks - 1] - x[pks] > thresh各ピーク値を、シリーズの次の谷ではなく、シリーズの直後の値と比較します。ピーク直後の関数の勾配のサイズの(粗い)推定値を使用し、その勾配がthreshサイズを超えるピークのみを選択します。あなたの場合、最初の3つのピークのみが、テストに合格するのに十分シャープです。デフォルトを使用して、すべてのピークを検出します。

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

30

私はwhuberの応答に同意しますが、コードの「+2」部分を追加したかっただけです。これは、新しく見つかったピークに一致するようにインデックスをシフトし、実際に「オーバーシュート」して「+1」にする必要があります。たとえば、手元の例では次のようになります。

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

これらのピークをグラフ上で強調表示すると(太字の赤): ここに画像の説明を入力してください

実際のピークから常に1ポイント離れていることがわかります。

結果

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

あるべきpks[x[pks] - x[pks + 1] > thresh]pks[x[pks] - x[pks - 1] > thresh]

大きな更新

適切なピーク検出機能を見つけるための私自身の探求に従って、私はこれを書きました:

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
}

「ピーク」とは、そのm両側の点がそれよりも小さい局所的な最大値として定義されます。したがって、パラメータが大きいほどm、ピーク資金調達手続きはより厳しくなります。そう:

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

この関数は、をx介して任意のシーケンシャルベクトルの極小値を見つけるためにも使用できfind_peaks(-x)ます

注:誰かがそれを必要とする場合、gitHubに関数を配置しました:https : //github.com/stas-g/findPeaks


6

Eek:マイナーアップデート。Stas_Gの関数と同等になるように、2行のコード、境界(-1と+1を追加)を変更する必要がありました(実際のデータセットでいくつかの「余分なピーク」が見つかりました)。私の最初の投稿では、誰もが謝罪することはほとんどありません。

私はかなり以前からStas_gのピーク検出アルゴリズムを使用しています。シンプルであるため、後のプロジェクトの1つにとって有益でした。ただし、計算に何百万回も使用する必要があるため、Rcppで書き直しました(Rcppパッケージを参照)。単純なテストでは、Rバージョンの約6倍高速です。誰かが興味を持っているなら、以下のコードを追加しました。誰か助けてくれたらいいな、乾杯!

いくつかの小さな警告。この関数は、Rコードの逆順でピークインデックスを返します。社内のC ++ Sign関数が必要です。完全に最適化されていませんが、それ以上のパフォーマンスの向上は期待できません。

//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

このforループには欠陥があるようです。@ caseyk:for(q = lb; q < rb; ++q){ if(vY(q) > vY(i+1)){ isGreatest = false; } }ループの最後の実行が「勝ち」、次と同等のことを行いますisGreatest = vY(rb-1) <= vY(rb)。:ちょうどそのライン主張上記のコメントは、forループに変更する必要があるであろうものを達成するにはfor(q = lb; isGreatest && (q < rb); ++q){ isGreatest = (vY(q) <= vY(i+1)) }
ベルンハルト・ワグナー

うーん。このコードを書いてから本当に長い時間が経ちました。IIRCはStas_Gの機能で直接テストされ、まったく同じ結果を維持しました。あなたの言っていることはわかりますが、出力にどのような違いがあるのか​​わかりません。私が提案/適応したソリューションとあなたのソリューションを調査することは、あなたにとっての投稿に値するでしょう。
ケーシーク

また、このスクリプトをおそらく100xのオーダーで個人的にテストし(これが私のプロジェクトのスクリプトであると仮定します)、100万回をはるかに超えて使用され、文献の結果と完全に一致する間接的な結果を提供しました特定のテストケース。だから、それが「欠陥」であれば、それは「欠陥」ではありません;)
caseyk

1

まず、アルゴリズムは、sign(diff(x, na.pad = FALSE)) 0から-1になり、差分も-1になるため、平坦なプラトーの右側へのドロップを誤って呼び出します。簡単な修正方法は、負のエントリの前のsign-diffがゼロではなく正であることを確認することです。

    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

2番目:アルゴリズムは非常に局所的な結果を出します。たとえば、シーケンス内の3つの連続した用語の実行で「アップ」と「ダウン」が続きます。ノイズのある連続関数の局所的な最大値に代わりに興味がある場合は、おそらく他にももっと良いものがありますが、これは私の安くて即時の解決策です

  1. 3つの連続したポイントの移動平均を使用して最初にピークを特定し
    、データをわずかに平滑化します。また、前述のフラットおよびドロップオフに対する制御を使用します。
  2. 黄土平滑化バージョンの場合、各ピークを中心とするウィンドウ内の平均を外部のローカル用語の平均と比較することにより、これらの候補をフィルタリングします。

    "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

関数はプラトーの終わりも識別しますが、別の簡単な修正方法があると思います:実際のピークの最初の差分は「1」、次に「-1」になるため、2番目の差分は「-2」になります。直接確認できます

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

これは質問に答えていないようです。
マイケルR.チャーニック

0

Numpyを使用する

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

または

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

パンダを使用して

ser = pd.Series(np.random.randint(2, 5, 100))
peak_df = ser[(ser.shift(1) < ser) & (ser.shift(-1) < ser)]
peak = peak_df.index
弊社のサイトを使用することにより、あなたは弊社のクッキーポリシーおよびプライバシーポリシーを読み、理解したものとみなされます。
Licensed under cc by-sa 3.0 with attribution required.