Ich suche nach einem rechnerisch effizienten Weg, um lokale Maxima / Minima für eine große Liste von Zahlen in R zu finden. Hoffentlich ohne forSchleifen ...

Wenn ich beispielsweise eine Datendatei wie habe 1 2 3 2 1 1 2 1, möchte ich, dass die Funktion 3 und 7 zurückgibt , die die Positionen der lokalen Maxima sind.

diff(diff(x))(oder diff(x,differences=2): dank @ZheyuanLi) berechnet im Wesentlichen das diskrete Analogon der zweiten Ableitung, sollte also bei lokalen Maxima negativ sein. Das +1Folgende berücksichtigt die Tatsache, dass das Ergebnis von diffkürzer als der Eingabevektor ist.

edit : @ Tommys Korrektur für Fälle hinzugefügt, in denen Delta-x nicht 1 ist ...

tt <- c(1,2,3,2,1, 1, 2, 1)
which(diff(sign(diff(tt)))==-2)+1

Mein Vorschlag oben ( http://statweb.stanford.edu/~tibs/PPC/Rdist/ ) ist für den Fall gedacht, dass die Daten lauter sind.

@ Bens Lösung ist ziemlich süß. Die folgenden Fälle werden jedoch nicht behandelt:

# all these return numeric(0):
x <- c(1,2,9,9,2,1,1,5,5,1) # duplicated points at maxima 
which(diff(sign(diff(x)))==-2)+1 
x <- c(2,2,9,9,2,1,1,5,5,1) # duplicated points at start
which(diff(sign(diff(x)))==-2)+1 
x <- c(3,2,9,9,2,1,1,5,5,1) # start is maxima
which(diff(sign(diff(x)))==-2)+1

Hier ist eine robustere (und langsamere, hässlichere) Version:

localMaxima <- function(x) {
  # Use -Inf instead if x is numeric (non-integer)
  y <- diff(c(-.Machine$integer.max, x)) > 0L
  rle(y)$lengths
  y <- cumsum(rle(y)$lengths)
  y <- y[seq.int(1L, length(y), 2L)]
  if (x[[1]] == x[[2]]) {
    y <- y[-1]
  }
  y
}

x <- c(1,2,9,9,2,1,1,5,5,1)
localMaxima(x) # 3, 8
x <- c(2,2,9,9,2,1,1,5,5,1)
localMaxima(x) # 3, 8
x <- c(3,2,9,9,2,1,1,5,5,1)
localMaxima(x) # 1, 3, 8

Verwenden Sie die Zoobibliotheksfunktion rollapply:

x <- c(1, 2, 3, 2, 1, 1, 2, 1)
library(zoo)
 xz <- as.zoo(x)
 rollapply(xz, 3, function(x) which.min(x)==2)
#    2     3     4     5     6     7 
#FALSE FALSE FALSE  TRUE FALSE FALSE 
 rollapply(xz, 3, function(x) which.max(x)==2)
#    2     3     4     5     6     7 
#FALSE  TRUE FALSE FALSE FALSE  TRUE 

Ziehen Sie dann den Index mit den 'Coredata' für die Werte, wobei 'which.max' ein "Mittelpunkt" ist, der ein lokales Maximum signalisiert. Sie könnten natürlich dasselbe für lokale Minima tun, indem Sie which.minanstelle von verwenden which.max.

 rxz <- rollapply(xz, 3, function(x) which.max(x)==2)
 index(rxz)[coredata(rxz)]
#[1] 3 7

Ich gehe davon aus, dass Sie die Start- oder Endwerte nicht möchten, aber wenn Sie dies tun, können Sie die Enden Ihrer Vektoren vor der Verarbeitung auffüllen, ähnlich wie es Telomere auf Chromosomen tun.

(Ich nehme das ppc-Paket zur Kenntnis ("Peak Probability Contrasts" für Massenspektrometrieanalysen, einfach weil ich bis zum Lesen des obigen Kommentars von @ BenBolker nicht über dessen Verfügbarkeit informiert war, und ich denke, dass das Hinzufügen dieser wenigen Wörter die Wahrscheinlichkeit erhöht, dass jemand mit einem Massenspezifikationsinteresse wird dies bei einer Suche sehen.)

Ich habe heute einen Stich gemacht. Ich weiß, dass Sie hoffentlich ohne for-Schleifen gesagt haben, aber ich habe mich an die Apply-Funktion gehalten. Etwas kompakt und schnell und ermöglicht die Angabe von Schwellenwerten, sodass Sie mehr als 1 erreichen können.

Die Funktion:

inflect <- function(x, threshold = 1){
  up   <- sapply(1:threshold, function(n) c(x[-(seq(n))], rep(NA, n)))
  down <-  sapply(-1:-threshold, function(n) c(rep(NA,abs(n)), x[-seq(length(x), length(x) - abs(n) + 1)]))
  a    <- cbind(x,up,down)
  list(minima = which(apply(a, 1, min) == a[,1]), maxima = which(apply(a, 1, max) == a[,1]))
}

Um es zu visualisieren / mit Schwellenwerten zu spielen, können Sie den folgenden Code ausführen:

# Pick a desired threshold # to plot up to
n <- 2
# Generate Data
randomwalk <- 100 + cumsum(rnorm(50, 0.2, 1)) # climbs upwards most of the time
bottoms <- lapply(1:n, function(x) inflect(randomwalk, threshold = x)$minima)
tops <- lapply(1:n, function(x) inflect(randomwalk, threshold = x)$maxima)
# Color functions
cf.1 <- grDevices::colorRampPalette(c("pink","red"))
cf.2 <- grDevices::colorRampPalette(c("cyan","blue"))
plot(randomwalk, type = 'l', main = "Minima & Maxima\nVariable Thresholds")
for(i in 1:n){
  points(bottoms[[i]], randomwalk[bottoms[[i]]], pch = 16, col = cf.1(n)[i], cex = i/1.5)
}
for(i in 1:n){
  points(tops[[i]], randomwalk[tops[[i]]], pch = 16, col = cf.2(n)[i], cex = i/1.5)
}
legend("topleft", legend = c("Minima",1:n,"Maxima",1:n), 
       pch = rep(c(NA, rep(16,n)), 2), col = c(1, cf.1(n),1, cf.2(n)), 
       pt.cex =  c(rep(c(1, c(1:n) / 1.5), 2)), cex = .75, ncol = 2)

Es gibt einige gute Lösungen, aber es hängt davon ab, was Sie brauchen.

Gerade diff(tt) gibt die Unterschiede.

Sie möchten erkennen, wann Sie von steigenden zu abnehmenden Werten wechseln. Eine Möglichkeit, dies zu tun, bietet @Ben:

 diff(sign(diff(tt)))==-2

Das Problem hierbei ist, dass nur Änderungen erkannt werden, die sofort von streng ansteigend auf streng abnehmend übergehen.

Eine geringfügige Änderung ermöglicht wiederholte Werte am Peak (Rückkehr TRUEzum letzten Auftreten des Peakwerts):

 diff(diff(x)>=0)<0

Dann müssen Sie einfach die Vorder- und Rückseite richtig auffüllen, wenn Sie Maxima am Anfang oder Ende von erkennen möchten

Hier ist alles in einer Funktion verpackt (einschließlich der Suche nach Tälern):

 which.peaks <- function(x,partial=TRUE,decreasing=FALSE){
     if (decreasing){
         if (partial){
             which(diff(c(FALSE,diff(x)>0,TRUE))>0)
         }else {
             which(diff(diff(x)>0)>0)+1
         }
     }else {
         if (partial){
             which(diff(c(TRUE,diff(x)>=0,FALSE))<0)
         }else {
             which(diff(diff(x)>=0)<0)+1
         }
     }
 }

Spät zur Party, aber das könnte für andere von Interesse sein. Sie können heutzutage die (interne) Funktion find_peaksaus dem ggpmiscPaket verwenden. Sie können parametrisieren es mit threshold, spanund strictArgumente. Da das ggpmiscPaket für die Verwendung mit vorgesehen ist ggplot2, können Sie Minima und Maxima direkt mit den Funktionen stat_peaksund zeichnen stat_valleys:

set.seed(1)
x <- 1:10
y <- runif(10)
# Maxima
x[ggpmisc:::find_peaks(y)]
[1] 4 7
y[ggpmisc:::find_peaks(y)]
[1] 0.9082078 0.9446753
# Minima
x[ggpmisc:::find_peaks(-y)]
[1] 5
y[ggpmisc:::find_peaks(-y)]
[1] 0.2016819    
# Plot
ggplot(data = data.frame(x, y), aes(x = x, y = y)) + geom_line() + stat_peaks(col = "red") + stat_valleys(col = "green")

Die Antwort von @ 42- ist großartig, aber ich hatte einen Anwendungsfall, den ich nicht verwenden wollte zoo. Es ist einfach , dies zu implementieren mit dplyrVerwendung lagund lead:

library(dplyr)
test = data_frame(x = sample(1:10, 20, replace = TRUE))
mutate(test, local.minima = if_else(lag(x) > x & lead(x) > x, TRUE, FALSE)

Wie die rollapplyLösung, können Sie die Fenstergröße und Grenzfälle steuern durch die lag/ leadArgumente nund defaultsind.

In dem Fall, an dem ich arbeite, sind Duplikate häufig. Also habe ich eine Funktion implementiert, die es ermöglicht, erste oder letzte Extrema (min oder max) zu finden:

locate_xtrem <- function (x, last = FALSE)
{
  # use rle to deal with duplicates
  x_rle <- rle(x)

  # force the first value to be identified as an extrema
  first_value <- x_rle$values[1] - x_rle$values[2]

  # differentiate the series, keep only the sign, and use 'rle' function to
  # locate increase or decrease concerning multiple successive values.
  # The result values is a series of (only) -1 and 1.
  #
  # ! NOTE: with this method, last value will be considered as an extrema
  diff_sign_rle <- c(first_value, diff(x_rle$values)) %>% sign() %>% rle()

  # this vector will be used to get the initial positions
  diff_idx <- cumsum(diff_sign_rle$lengths)

  # find min and max
  diff_min <- diff_idx[diff_sign_rle$values < 0]
  diff_max <- diff_idx[diff_sign_rle$values > 0]

  # get the min and max indexes in the original series
  x_idx <- cumsum(x_rle$lengths)
  if (last) {
    min <- x_idx[diff_min]
    max <- x_idx[diff_max]
  } else {
    min <- x_idx[diff_min] - x_rle$lengths[diff_min] + 1
    max <- x_idx[diff_max] - x_rle$lengths[diff_max] + 1
  }
  # just get number of occurences
  min_nb <- x_rle$lengths[diff_min]
  max_nb <- x_rle$lengths[diff_max]

  # format the result as a tibble
  bind_rows(
    tibble(Idx = min, Values = x[min], NB = min_nb, Status = "min"),
    tibble(Idx = max, Values = x[max], NB = max_nb, Status = "max")) %>%
    arrange(.data$Idx) %>%
    mutate(Last = last) %>%
    mutate_at(vars(.data$Idx, .data$NB), as.integer)
}

Die Antwort auf die ursprüngliche Frage lautet:

> x <- c(1, 2, 3, 2, 1, 1, 2, 1)
> locate_xtrem(x)
# A tibble: 5 x 5
    Idx Values    NB Status Last 
  <int>  <dbl> <int> <chr>  <lgl>
1     1      1     1 min    FALSE
2     3      3     1 max    FALSE
3     5      1     2 min    FALSE
4     7      2     1 max    FALSE
5     8      1     1 min    FALSE

Das Ergebnis zeigt an, dass das zweite Minimum gleich 1 ist und dass dieser Wert ab Index 5 zweimal wiederholt wird. Daher könnte ein anderes Ergebnis erhalten werden, indem der Funktion diese Zeit angezeigt wird, um das letzte Auftreten lokaler Extreme zu finden:

> locate_xtrem(x, last = TRUE)
# A tibble: 5 x 5
    Idx Values    NB Status Last 
  <int>  <dbl> <int> <chr>  <lgl>
1     1      1     1 min    TRUE 
2     3      3     1 max    TRUE 
3     6      1     2 min    TRUE 
4     7      2     1 max    TRUE 
5     8      1     1 min    TRUE 

Je nach Ziel ist es dann möglich, zwischen dem ersten und dem letzten Wert eines lokalen Extremas umzuschalten. Das zweite Ergebnis mitlast = TRUE könnte auch aus einer Operation zwischen den Spalten "Idx" und "NB" erhalten werden ...

Um schließlich mit Rauschen in den Daten umzugehen, könnte eine Funktion implementiert werden, um Schwankungen unterhalb eines bestimmten Schwellenwerts zu entfernen. Code wird nicht angezeigt, da er über die ursprüngliche Frage hinausgeht. Ich habe es in ein Paket verpackt (hauptsächlich, um den Testprozess zu automatisieren) und gebe unten ein Ergebnisbeispiel:

x_series %>% xtrem::locate_xtrem()

x_series %>% xtrem::locate_xtrem() %>% remove_noise()

Hier ist die Lösung für Minima :

@ Bens Lösung

x <- c(1,2,3,2,1,2,1)
which(diff(sign(diff(x)))==+2)+1 # 5

Bitte beachten Sie die Fälle bei Tommy!

@ Tommys Lösung:

localMinima <- function(x) {
  # Use -Inf instead if x is numeric (non-integer)
  y <- diff(c(.Machine$integer.max, x)) > 0L
  rle(y)$lengths
  y <- cumsum(rle(y)$lengths)
  y <- y[seq.int(1L, length(y), 2L)]
  if (x[[1]] == x[[2]]) {
    y <- y[-1]
  }
  y
}

x <- c(1,2,9,9,2,1,1,5,5,1)
localMinima(x) # 1, 7, 10
x <- c(2,2,9,9,2,1,1,5,5,1)
localMinima(x) # 7, 10
x <- c(3,2,9,9,2,1,1,5,5,1)
localMinima(x) # 2, 7, 10

Bitte beachten Sie: Weder können localMaximanoch localMinimadoppelte Maxima / Minima beim Start verarbeitet werden!

Ich hatte einige Probleme damit, die Standorte in früheren Lösungen zum Laufen zu bringen, und fand eine Möglichkeit, die Minima und Maxima direkt zu erfassen. Der folgende Code erledigt dies und zeichnet es, wobei die Minima in Grün und die Maxima in Rot markiert werden. Im Gegensatz zur which.max()Funktion werden dadurch alle Indizes der Minima / Maxima aus einem Datenrahmen gezogen. Der Nullwert wird in der ersten diff()Funktion addiert , um die fehlende verringerte Länge des Ergebnisses zu berücksichtigen, die bei jeder Verwendung der Funktion auftritt. Das Einfügen in den innersten diff()Funktionsaufruf erspart das Hinzufügen eines Offsets außerhalb des logischen Ausdrucks. Es macht nicht viel aus, aber ich denke, es ist eine sauberere Art, es zu tun.

# create example data called stockData
stockData = data.frame(x = 1:30, y=rnorm(30,7))

# get the location of the minima/maxima. note the added zero offsets  
# the location to get the correct indices
min_indexes = which(diff(  sign(diff( c(0,stockData$y)))) == 2)
max_indexes = which(diff(  sign(diff( c(0,stockData$y)))) == -2)

# get the actual values where the minima/maxima are located
min_locs = stockData[min_indexes,]
max_locs = stockData[max_indexes,]

# plot the data and mark minima with red and maxima with green
plot(stockData$y, type="l")
points( min_locs, col="red", pch=19, cex=1  )
points( max_locs, col="green", pch=19, cex=1  )

Im pracmaPaket, verwenden Sie die

tt <- c(1,2,3,2,1, 1, 2, 1)
tt_peaks <- findpeaks(tt, zero = "0", peakpat = NULL,
       minpeakheight = -Inf, minpeakdistance = 1, threshold = 0, npeaks = 0, sortstr = FALSE)

  [,1] [,2] [,3] [,4]
  [1,]  3    3    1    5
  [2,]  2    7    6    8

Das gibt eine Matrix mit 4 Spalten zurück. Die erste Spalte zeigt die absoluten Werte der lokalen Peaks. Die 2. Spalte sind die Indizes. Die 3. und 4. Spalte sind der Anfang und das Ende der Peaks (mit möglicher Überlappung).

Weitere Informationen finden Sie unter https://www.rdocumentation.org/packages/pracma/versions/1.9.9/topics/findpeaks .

Eine Einschränkung: Ich habe es in einer Reihe von Nicht-Ganzzahlen verwendet, und der Peak war einen Index zu spät (für alle Peaks), und ich weiß nicht warum. Also musste ich "1" manuell aus meinem Indexvektor entfernen (keine große Sache).

Das Finden lokaler Maxima und Minima für eine nicht so einfache Sequenz, z. B. 1 0 1 1 2 0 1 1 0 1 1 1 0 1würde ich ihre Positionen bei (1), 5, 7.5, 11 und (14) für Maxima und 2, 6, 9, 13 für Minima angeben.

#Position                1 1 1 1 1
#      1 2 3 4 5 6 7 8 9 0 1 2 3 4
x <- c(1,0,1,1,2,0,1,1,0,1,1,1,0,1) #Frequency
#      p v     p v  p  v   p   v p  p..Peak, v..Valey

peakPosition <- function(x, inclBorders=TRUE) {
  if(inclBorders) {y <- c(min(x), x, min(x))
  } else {y <- c(x[1], x)}
  y <- data.frame(x=sign(diff(y)), i=1:(length(y)-1))
  y <- y[y$x!=0,]
  idx <- diff(y$x)<0
  (y$i[c(idx,F)] + y$i[c(F,idx)] - 1)/2
}

#Find Peaks
peakPosition(x)
#1.0  5.0  7.5 11.0 14.0

#Find Valeys
peakPosition(-x)
#2  6  9 13

peakPosition(c(1,2,3,2,1,1,2,1)) #3 7

Diese Funktion von Timothée Poisot ist praktisch für laute Serien:

3. Mai 2009
Ein Algorithmus zum Auffinden lokaler Extrema in einem Vektor
Abgelegt unter: Algorithmus - Tags: Extrema, Zeitreihe - Timothée Poisot @ 6:46 pm

Ich verbringe einige Zeit damit, nach einem Algorithmus zu suchen, um lokale Extrema in einem Vektor (Zeitreihen) zu finden. Die Lösung, die ich verwendet habe, besteht darin, den Vektor schrittweise größer als 1 zu durchlaufen, um nur einen Wert beizubehalten, selbst wenn die Werte sehr verrauscht sind (siehe das Bild am Ende des Beitrags).

Es geht so :

findpeaks <- function(vec,bw=1,x.coo=c(1:length(vec)))
{
    pos.x.max <- NULL
    pos.y.max <- NULL
    pos.x.min <- NULL
    pos.y.min <- NULL   for(i in 1:(length(vec)-1))     {       if((i+1+bw)>length(vec)){
                sup.stop <- length(vec)}else{sup.stop <- i+1+bw
                }
        if((i-bw)<1){inf.stop <- 1}else{inf.stop <- i-bw}
        subset.sup <- vec[(i+1):sup.stop]
        subset.inf <- vec[inf.stop:(i-1)]

        is.max   <- sum(subset.inf > vec[i]) == 0
        is.nomin <- sum(subset.sup > vec[i]) == 0

        no.max   <- sum(subset.inf > vec[i]) == length(subset.inf)
        no.nomin <- sum(subset.sup > vec[i]) == length(subset.sup)

        if(is.max & is.nomin){
            pos.x.max <- c(pos.x.max,x.coo[i])
            pos.y.max <- c(pos.y.max,vec[i])
        }
        if(no.max & no.nomin){
            pos.x.min <- c(pos.x.min,x.coo[i])
            pos.y.min <- c(pos.y.min,vec[i])
        }
    }
    return(list(pos.x.max,pos.y.max,pos.x.min,pos.y.min))
}

Link zum ursprünglichen Blog-Beitrag

Ich habe dies an anderer Stelle gepostet, aber ich denke, dies ist ein interessanter Weg, dies zu tun. Ich bin nicht sicher, wie hoch die Recheneffizienz ist, aber es ist eine sehr präzise Methode, um das Problem zu lösen.

vals=rbinom(1000,20,0.5)

text=paste0(substr(format(diff(vals),scientific=TRUE),1,1),collapse="")

sort(na.omit(c(gregexpr('[ ]-',text)[[1]]+1,ifelse(grepl('^-',text),1,NA),
 ifelse(grepl('[^-]$',text),length(vals),NA))))

Wir sehen hier viele schöne Funktionen und Ideen mit unterschiedlichen Funktionen. Ein Problem fast aller Beispiele ist die Effizienz. Oft sehen wir die Verwendung komplexer Funktionen wie diff()oder for()-loops, die langsam werden, wenn große Datenmengen beteiligt sind. Lassen Sie mich eine effiziente Funktion vorstellen, die ich jeden Tag benutze, mit minimalen Funktionen, aber sehr schnell:

Lokale Maxima-Funktion amax()

Der Zweck besteht darin, alle lokalen Maxima in einem reellen Vektor zu erfassen. Wenn das erste Element x[1]das globale Maximum ist, wird es ignoriert, da keine Informationen zur vorherigen Emlementierung vorhanden sind. Wenn es ein Plateau gibt, wird die erste Kante erkannt.

@param x numerischer Vektor

@return gibt die Angaben der lokalen Maxima zurück. Wenn x[1] = max, dann wird es ignoriert.

amax <- function(x)
{
  a1 <- c(0,x,0)
  a2 <- c(x,0,0)
  a3 <- c(0,0,x)
  e <- which((a1 >= a2 & a1 > a3)[2:(length(x))])
  if(!is.na(e[1] == 1))
    if(e[1]==1)
      e <- e[-1]
  if(length(e) == 0) e <- NaN
  return (e)
}

a <- c(1,2,3,2,1,5,5,4)
amax(a) # 3, 6

Eine kleine Verbesserung der von @BEN vorgeschlagenen Formel und der von @TOMMY vorgeschlagenen Fälle:

which(diff(abs(sign(diff(x)))-sign(diff(x)))==2)+1 %for local maximum
which(diff(abs(sign(diff(x)))-sign(diff(x)))==-2)+1 %for local minimum