Calcul de la moyenne mobile

J'essaie d'utiliser R pour calculer la moyenne mobile sur une série de valeurs dans une matrice. La recherche normale de la liste de diffusion R n'a cependant pas été très utile. Il ne semble pas y avoir de fonction intégrée dans R me permettra de calculer des moyennes mobiles. Certains forfaits en fournissent-ils un? Ou dois-je écrire le mien?

• Moyennes roulantes / maximums / médianes dans le package zoo (rollmean)
• MovingAverages dans TTR
• ma en prévision

Ou vous pouvez simplement le calculer en utilisant le filtre, voici la fonction que j'utilise:

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

Si vous utilisez dplyr, veillez à le spécifier stats::filterdans la fonction ci-dessus.

L'utilisation cumsumdoit être suffisante et efficace. En supposant que vous ayez un vecteur x et que vous vouliez une somme courante de n nombres

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

Comme indiqué dans les commentaires de @mzuther, cela suppose qu'il n'y a pas de NA dans les données. pour faire face à ceux-ci, il faudrait diviser chaque fenêtre par le nombre de valeurs non NA. Voici une façon de le faire, en intégrant le commentaire de @Ricardo Cruz:

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

Cela a toujours le problème que si toutes les valeurs de la fenêtre sont des NA, il y aura une division par zéro erreur.

Dans data.table 1.12.0 nouvelle frollmeanfonction a été ajoutée pour le calcul rapide et exact de roulement moyen de manipulation avec soin NA, NaNet +Inf, des -Infvaleurs.

Comme il n'y a pas d'exemple reproductible dans la question, il n'y a pas grand-chose d'autre à traiter ici.

Vous pouvez trouver plus d'informations sur ?frollmeandans le manuel, également disponible en ligne à l'adresse ?frollmean.

Exemples du manuel ci-dessous:

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

Le caToolspaquet a un roulement très rapide moyen / min / max / sd et quelques autres fonctions. J'ai seulement travaillé avec runmeanet runsdet ils sont les plus rapides de tous les autres packages mentionnés à ce jour.

Vous pouvez utiliser RcppRollpour des moyennes mobiles très rapides écrites en C ++. Appelez simplement la roll_meanfonction. Les documents peuvent être trouvés ici .

Sinon, cette boucle for (plus lente) devrait faire l'affaire:

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

En fait, RcppRollc'est très bien.

Le code affiché par cantdutch cela doit être corrigé dans la quatrième ligne de la fenêtre être corrigé:

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

Une autre manière, qui gère les manquements, est donnée ici .

Une troisième façon, d'améliorer cantdutchce code pour calculer des moyennes partielles ou non, suit:

  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,...)]
  }
}

Afin de compléter la réponse de cantdutchthis et Rodrigo Remedio ;

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)

Voici un exemple de code montrant comment calculer une moyenne mobile centrée et une moyenne mobile finale à l'aide de la rollmeanfonction du package zoo .

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

Bien qu'un peu lent mais vous pouvez également utiliser zoo :: rollapply pour effectuer des calculs sur des matrices.

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

où x est l'ensemble de données, FUN = mean est la fonction; vous pouvez également le changer en min, max, sd, etc. et la largeur est la fenêtre déroulante.

On peut utiliser un runnerpackage pour déplacer des fonctions. Dans ce cas, mean_runfonction. Le problème, cummeanc'est qu'il ne gère pas les NAvaleurs, mais le mean_runfait. runnerLe package prend également en charge les séries chronologiques irrégulières et les fenêtres peuvent dépendre de la date:

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

On peut également spécifier d'autres options comme lag, et rouler uniquement atdes index spécifiques. Plus d'informations dans la documentation des packages et des fonctions .

Le package slider peut être utilisé pour cela. Il a une interface qui a été spécialement conçue pour se sentir similaire à purrr. Il accepte n'importe quelle fonction arbitraire et peut renvoyer n'importe quel type de sortie. Les trames de données sont même itérées par ligne. Le site de pkgdown est ici .

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

La surcharge du curseur et de la table data.table frollapply()devrait être assez faible (beaucoup plus rapide que zoo). frollapply()semble être un peu plus rapide pour cet exemple simple ici, mais notez qu'il ne prend qu'une entrée numérique et que la sortie doit être une valeur numérique scalaire. Les fonctions de curseur sont complètement génériques et vous pouvez renvoyer n'importe quel type de données.

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))
}