Hareketli ortalamanın hesaplanması

Bir matristeki değerler dizisi üzerinde hareketli ortalama hesaplamak için R kullanmaya çalışıyorum. Normal R posta listesi araması çok yardımcı olmadı. R'de hareketli bir ortalama hesaplamama izin verecek yerleşik bir fonksiyon yok gibi görünüyor . Herhangi bir paket bir tane sunuyor mu? Yoksa kendim yazmak zorunda mıyım?

• Hayvanat bahçesi paketindeki Yuvarlanma Araçları / Maksimumlar / Medyalar (rollmean)
• Hareketli Ortalamalar TTR
• tahmini olarak ma

Ya da filtreyi kullanarak hesaplayabilirsiniz, işte kullandığım işlev:

ma <- function(x, n = 5){filter(x, rep(1 / n, n), sides = 2)}

Kullanıyorsanız dplyr, stats::filteryukarıdaki işlevde belirtmeye dikkat edin .

Kullanımı cumsumyeterli ve verimli olmalıdır. X vektörünüz olduğunu ve toplam n sayı istediğinizi varsayarsak

cx <- c(0,cumsum(x))
rsum <- (cx[(n+1):length(cx)] - cx[1:(length(cx) - n)]) / n

@Mzuther tarafından yapılan yorumlarda belirtildiği gibi, bu verilerde NA bulunmadığını varsayar. bunlarla başa çıkmak için her pencerenin NA olmayan değerlerin sayısına bölünmesi gerekir. @Ricardo Cruz'un yorumuyla bunu yapmanın bir yolu:

cx <- c(0, cumsum(ifelse(is.na(x), 0, x)))
cn <- c(0, cumsum(ifelse(is.na(x), 0, 1)))
rx <- cx[(n+1):length(cx)] - cx[1:(length(cx) - n)]
rn <- cn[(n+1):length(cx)] - cn[1:(length(cx) - n)]
rsum <- rx / rn

Bu hala penceredeki tüm değerlerin NA olması durumunda sıfır hata ile bölünme sorunu vardır.

Gelen data.table 1.12.0 yeni frollmeanfonksiyon hızlı ve kesin dikkatle ortalama haddeleme taşıma hesaplamak için eklenmiştir NA, NaNve +Inf, -Infdeğerler.

Soruda tekrarlanabilir bir örnek olmadığından, burada ele alınacak çok fazla bir şey yoktur.

Hakkında daha fazla bilgiyi ?frollmeanel kitabında, çevrimiçi olarak da bulabilirsiniz ?frollmean.

Aşağıdaki kılavuzdan örnekler:

library(data.table)
d = as.data.table(list(1:6/2, 3:8/4))

# rollmean of single vector and single window
frollmean(d[, V1], 3)

# multiple columns at once
frollmean(d, 3)

# multiple windows at once
frollmean(d[, .(V1)], c(3, 4))

# multiple columns and multiple windows at once
frollmean(d, c(3, 4))

## three above are embarrassingly parallel using openmp

caToolsPaket çok hızlı ortalama / min / max / sd ve birkaç diğer işlevleri haddeleme gelmiştir. Ben sadece çalıştım runmeanve runsdbugüne kadar bahsedilen diğer paketlerin en hızlısı.

RcppRollC ++ ile yazılmış çok hızlı hareketli ortalamalar için kullanabilirsiniz . Sadece roll_meanfonksiyonu çağırınız. Dokümanları burada bulabilirsiniz .

Aksi takdirde, döngü için bu (yavaş) hile yapmalıdır:

ma <- function(arr, n=15){
  res = arr
  for(i in n:length(arr)){
    res[i] = mean(arr[(i-n):i])
  }
  res
}

Aslında RcppRollçok iyi.

Cantdutch tarafından gönderilen kod, düzeltilecek pencerenin dördüncü satırında düzeltilmelidir:

ma <- function(arr, n=15){
  res = arr
  for(i in n:length(arr)){
    res[i] = mean(arr[(i-n+1):i])
  }
  res
}

Eksikleri işleyen başka bir yol da burada verilmiştir .

Üçüncü bir yol, iyileştirilmesi cantdutchthis kodu, kısmi ortalamaları hesaplamak ya da değil, aşağıdaki gibidir:

  ma <- function(x, n=2,parcial=TRUE){
  res = x #set the first values

  if (parcial==TRUE){
    for(i in 1:length(x)){
      t<-max(i-n+1,1)
      res[i] = mean(x[t:i])
    }
    res

  }else{
    for(i in 1:length(x)){
      t<-max(i-n+1,1)
      res[i] = mean(x[t:i])
    }
    res[-c(seq(1,n-1,1))] #remove the n-1 first,i.e., res[c(-3,-4,...)]
  }
}

Cantdutchthis ve Rodrigo Remedio'nun cevabını tamamlamak için ;

moving_fun <- function(x, w, FUN, ...) {
  # x: a double vector
  # w: the length of the window, i.e., the section of the vector selected to apply FUN
  # FUN: a function that takes a vector and return a summarize value, e.g., mean, sum, etc.
  # Given a double type vector apply a FUN over a moving window from left to the right, 
  #    when a window boundary is not a legal section, i.e. lower_bound and i (upper bound) 
  #    are not contained in the length of the vector, return a NA_real_
  if (w < 1) {
    stop("The length of the window 'w' must be greater than 0")
  }
  output <- x
  for (i in 1:length(x)) {
     # plus 1 because the index is inclusive with the upper_bound 'i'
    lower_bound <- i - w + 1
    if (lower_bound < 1) {
      output[i] <- NA_real_
    } else {
      output[i] <- FUN(x[lower_bound:i, ...])
    }
  }
  output
}

# example
v <- seq(1:10)

# compute a MA(2)
moving_fun(v, 2, mean)

# compute moving sum of two periods
moving_fun(v, 2, sum)

Burada, hayvanat bahçesi paketindeki işlevi kullanarak ortalanmış bir hareketli ortalamanın ve sondaki hareketli bir ortalamanın nasıl hesaplanacağını gösteren örnek kod verilmiştir .rollmean

library(tidyverse)
library(zoo)

some_data = tibble(day = 1:10)
# cma = centered moving average
# tma = trailing moving average
some_data = some_data %>%
    mutate(cma = rollmean(day, k = 3, fill = NA)) %>%
    mutate(tma = rollmean(day, k = 3, fill = NA, align = "right"))
some_data
#> # A tibble: 10 x 3
#>      day   cma   tma
#>    <int> <dbl> <dbl>
#>  1     1    NA    NA
#>  2     2     2    NA
#>  3     3     3     2
#>  4     4     4     3
#>  5     5     5     4
#>  6     6     6     5
#>  7     7     7     6
#>  8     8     8     7
#>  9     9     9     8
#> 10    10    NA     9

Biraz yavaş olsa da, matrisler üzerinde hesaplamalar yapmak için zoo :: rollapply komutunu da kullanabilirsiniz.

reqd_ma <- rollapply(x, FUN = mean, width = n)

burada x veri kümesidir, FUN = ortalama işlevdir; Ayrıca min, maks, sd vb olarak değiştirebilirsiniz ve genişlik yuvarlanan penceredir.

runnerHareketli fonksiyonlar için paket kullanılabilir . Bu durumda mean_runişlev. Sorun, değerleri cummeanişlememesi değil, işlemesidir . paket ayrıca düzensiz zaman serilerini destekler ve pencereler tarihe bağlı olabilir:NAmean_runrunner

library(runner)
set.seed(11)
x1 <- rnorm(15)
x2 <- sample(c(rep(NA,5), rnorm(15)), 15, replace = TRUE)
date <- Sys.Date() + cumsum(sample(1:3, 15, replace = TRUE))

mean_run(x1)
#>  [1] -0.5910311 -0.2822184 -0.6936633 -0.8609108 -0.4530308 -0.5332176
#>  [7] -0.2679571 -0.1563477 -0.1440561 -0.2300625 -0.2844599 -0.2897842
#> [13] -0.3858234 -0.3765192 -0.4280809

mean_run(x2, na_rm = TRUE)
#>  [1] -0.18760011 -0.09022066 -0.06543317  0.03906450 -0.12188853 -0.13873536
#>  [7] -0.13873536 -0.14571604 -0.12596067 -0.11116961 -0.09881996 -0.08871569
#> [13] -0.05194292 -0.04699909 -0.05704202

mean_run(x2, na_rm = FALSE )
#>  [1] -0.18760011 -0.09022066 -0.06543317  0.03906450 -0.12188853 -0.13873536
#>  [7]          NA          NA          NA          NA          NA          NA
#> [13]          NA          NA          NA

mean_run(x2, na_rm = TRUE, k = 4)
#>  [1] -0.18760011 -0.09022066 -0.06543317  0.03906450 -0.10546063 -0.16299272
#>  [7] -0.21203756 -0.39209010 -0.13274756 -0.05603811 -0.03894684  0.01103493
#> [13]  0.09609256  0.09738460  0.04740283

mean_run(x2, na_rm = TRUE, k = 4, idx = date)
#> [1] -0.187600111 -0.090220655 -0.004349696  0.168349653 -0.206571573 -0.494335093
#> [7] -0.222969541 -0.187600111 -0.087636571  0.009742884  0.009742884  0.012326968
#> [13]  0.182442234  0.125737145  0.059094786

Ayrıca lag, diğer atbelirli seçenekler belirtilebilir ve yalnızca belirli dizinler döndürülebilir. Paket ve işlev belgelerinde daha fazlası .

Kaydırma paketi bunun için kullanılabilir. Purrr'a benzemek için özel olarak tasarlanmış bir arayüze sahiptir. Herhangi bir keyfi işlevi kabul eder ve herhangi bir çıktı türünü döndürebilir. Veri çerçeveleri satır bazında bile yinelenir. Pkgdown sitesi burada .

library(slider)

x <- 1:3

# Mean of the current value + 1 value before it
# returned as a double vector
slide_dbl(x, ~mean(.x, na.rm = TRUE), .before = 1)
#> [1] 1.0 1.5 2.5


df <- data.frame(x = x, y = x)

# Slide row wise over data frames
slide(df, ~.x, .before = 1)
#> [[1]]
#>   x y
#> 1 1 1
#> 
#> [[2]]
#>   x y
#> 1 1 1
#> 2 2 2
#> 
#> [[3]]
#>   x y
#> 1 2 2
#> 2 3 3

Hem kaydırıcı hem de veri yükü frollapply()oldukça düşük olmalıdır (hayvanat bahçesinden çok daha hızlı). frollapply()burada bu basit örnek için biraz daha hızlı görünüyor, ancak yalnızca sayısal girdi aldığını ve çıkışın skaler sayısal bir değer olması gerektiğini unutmayın. kaydırıcı işlevleri tamamen geneldir ve herhangi bir veri türünü döndürebilirsiniz.

library(slider)
library(zoo)
library(data.table)

x <- 1:50000 + 0L

bench::mark(
  slider = slide_int(x, function(x) 1L, .before = 5, .complete = TRUE),
  zoo = rollapplyr(x, FUN = function(x) 1L, width = 6, fill = NA),
  datatable = frollapply(x, n = 6, FUN = function(x) 1L),
  iterations = 200
)
#> # A tibble: 3 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 slider      19.82ms   26.4ms     38.4    829.8KB     19.0
#> 2 zoo        177.92ms  211.1ms      4.71    17.9MB     24.8
#> 3 datatable    7.78ms   10.9ms     87.9    807.1KB     38.7

vector_avg <- function(x){
  sum_x = 0
  for(i in 1:length(x)){
    if(!is.na(x[i]))
      sum_x = sum_x + x[i]
  }
  return(sum_x/length(x))
}

Sadece bunu kendileri hesaplamak isteyen insanlar için, bundan başka bir şey değildir:

# x = vector with numeric data
# n = window length
y <- numeric(length = length(x))

for (k in c(1:(n - 1))) {
  y[k] <- sum(x[1:k])
}
for (k in c(n:length(x))) {
  y[k] <- sum(x[(k - n + 1):k])
}

y

Ama onu bağımsız hale getirmek eğlenceli olur sum(), böylece herhangi bir 'hareketli' işlevi hesaplayabilirsiniz!

# our working horse:
moving_fn <- function(x, n, fun, ...) {
  # x = vector with numeric data
  # n = window length
  # fun = function to apply
  # ... = parameters passed on to 'fun'
  y <- numeric(length = length(x))

  for (k in c(1:(n - 1))) {
    y[k] <- fun(x[1:k], ...) # note the '...', it will include 'na.rm' when using in moving_average()
  }
  for (k in c(n:length(x))) {
    y[k] <- fun(x[(k - n + 1):k], ...)
  }
  return(y)
}

# and now any variation you can think of!
moving_average <- function(x, n = 5, na.rm = FALSE) {
  moving_fn(x = x, n = n, fun = mean, na.rm = na.rm)
}

moving_sum <- function(x, n = 5, na.rm = FALSE) {
  moving_fn(x = x, n = n, fun = sum, na.rm = na.rm)
}

moving_maximum <- function(x = 5, n, na.rm = FALSE) {
  moving_fn(x = x, n = n, fun = max, na.rm = na.rm)
}

moving_median <- function(x, n = 5, na.rm = FALSE) {
  moving_fn(x = x, n = n, fun = median, na.rm = na.rm)
}

Aşağıda, filterNA'ların dolgu ile başlayıp bitmesine özen göstermenin ve filterözel ağırlıklar kullanarak ağırlıklı bir ortalamanın (tarafından desteklenen ) hesaplanmasının bir yolunu gösteren basit bir işlev vardır :

wma <- function(x) { 
  wts <- c(seq(0.5, 4, 0.5), seq(3.5, 0.5, -0.5))
  nside <- (length(wts)-1)/2
  # pad x with begin and end values for filter to avoid NAs
  xp <- c(rep(first(x), nside), x, rep(last(x), nside)) 
  z <- stats::filter(xp, wts/sum(wts), sides = 2) %>% as.vector 
  z[(nside+1):(nside+length(x))]
}