cheat - xts r

Funciones de balanceo optimizadas en series de tiempo irregulares con ventana basada en el tiempo

Question

¿Hay alguna forma de usar las funciones optimizadas rollapply (del paquete zoo o algo similar) ( rollmean , rollmean , etc.) para calcular las funciones de balanceo con una ventana basada en el tiempo, en lugar de una basada en varias observaciones? Lo que quiero es simple: para cada elemento en una serie de tiempo irregular, quiero calcular una función de desplazamiento con una ventana de N días. Es decir, la ventana debe incluir todas las observaciones hasta N días antes de la observación actual. Las series de tiempo también pueden contener duplicados.

Aquí sigue un ejemplo. Dadas las siguientes series de tiempo:

 date value
1/11/2011 5
1/11/2011 4
1/11/2011 2
8/11/2011 1
13/11/2011 0
14/11/2011 0
15/11/2011 0
18/11/2011 1
21/11/2011 4
5/12/2011 3

Una mediana móvil con una ventana de 5 días, alineada a la derecha, debe resultar en el siguiente cálculo:

> c(
median(c(5)),
median(c(5,4)),
median(c(5,4,2)),
median(c(1)),
median(c(1,0)),
median(c(0,0)),
median(c(0,0,0)),
median(c(0,0,0,1)),
median(c(1,4)),
median(c(3))
)
[1] 5.0 4.5 4.0 1.0 0.5 0.0 0.0 0.0 2.5 3.0

Ya encontré algunas soluciones, pero generalmente son complicadas, lo que generalmente significa lento. Logré implementar mi propio cálculo de la función de laminación. El problema es que, para series de tiempo muy largas, la versión optimizada de median (rollmedian) puede hacer una gran diferencia de tiempo, ya que tiene en cuenta la superposición entre ventanas. Me gustaría evitar reimplementarla. Sospecho que hay algunos trucos con los parámetros rollapply que lo harán funcionar, pero no puedo resolverlo. Gracias de antemano por la ayuda.

Answer 1

Aquí están mis retoques con el problema. Si ese tipo de respuesta llega a lo que querías (no sé si es satisfactorio en términos de velocidad), puedo escribirlo como una respuesta más detallada (aunque esté basada en la idea de @ rbatt).

library(zoo)
library(dplyr)
# create a long time series
start <- as.Date("1800-01-01")
end <- as.Date(Sys.Date())
df <- data.frame(V1 = seq.Date(start, end, by = "day"))
df$V2 <- sample(1:10, nrow(df), replace = T)
# make it an irregular time series by sampling 10000 rows
# including allowing for duplicates (replace = T)
df2 <- df %>%
sample_n(10000, replace = T)
# create ''complete'' time series & join the data & compute the rolling median
df_rollmed <- data.frame(V1 = seq.Date(min(df$V1), max(df$V1), by = "day")) %>%
left_join(., df2) %>%
mutate(rollmed = rollapply(V2, 5, median, na.rm = T, align = "right", partial = T)) %>%
filter(!is.na(V2)) # throw out the NAs from the complete dataset

Answer 2

La mayoría de las respuestas sugieren insertar NA para que la serie de tiempo sea regular. Sin embargo, esto puede ser lento en caso de series de tiempo largas. Además, no funciona para funciones que no se pueden usar con NA.

El argumento de ancho de rollapply (paquete zoo) puede ser una lista (consulte la ayuda de rollapply para obtener más información). Sobre esta base, escribí una función que crea una lista para usar con rollapply como parámetro de ancho. La función extrae índices para objetos de zoológico irregulares si la ventana en movimiento debe basarse en el tiempo y no en el índice. Por lo tanto, el índice del objeto del zoológico debe ser el tiempo real.

# Create a zoo object where index represents time (e.g. in seconds)
d <- zoo(c(1,1,1,1,1,2,2,2,2,2,16,25,27,27,27,27,27,31),
c(1:5,11:15,16,25:30,31))
# Create function
createRollapplyWidth = function(zoodata, steps, window ){
mintime = min(time(zoodata))
maxtime = max(time(zoodata))
spotstime = seq(from = mintime , to = maxtime, by = steps)
spotsindex = list()
for (i in 1:length(spotstime)){
spotsindex[[i]] = as.numeric(which(spotstime[i] <= time(zoodata) & time(zoodata) < spotstime[i] + window))}
rollapplywidth = list()
for (i in 1:length(spotsindex)){
if (!is.na(median(spotsindex[[i]])) ){
rollapplywidth[[round(median(spotsindex[[i]]))]] = spotsindex[[i]] - round(median(spotsindex[[i]]))}
}
return(rollapplywidth)
}
# Create width parameter for rollapply using function
rollwidth = createRollapplyWidth(zoodata = d, steps = 5, window = 5)
# Use parameter in rollapply
result = rollapply(d, width = rollwidth , FUN = sum, na.rm = T)
result

Limitación: no se basa en la fecha sino en el tiempo en segundos. El parámetro "parcial" de rollapply no funciona.

Answer 3

No se ha verificado la velocidad, pero si no hay una fecha con más de max.dup ocurrencias, debe ser que las últimas 5 * max.dup entradas contengan los últimos 5 días, por lo que la función de una línea fn muestra a continuación pasó a rollapplyr . :

k <- 5
dates <- as.numeric(DF$date)
values <- DF$value
max.dup <- max(table(dates))
fn <- function(ix, d = dates[ix], v = values[ix], n = length(ix)) median(v[d >= d[n]-k])
rollapplyr(1:nrow(DF), max.dup * k, fn, partial = TRUE)
## [1] 5.0 4.5 4.0 1.0 0.5 0.0 0.0 0.0 2.5 3.0

Nota: Usamos esto para el DF :

 Lines <- "
date value
1/11/2011 5
1/11/2011 4
1/11/2011 2
8/11/2011 1
13/11/2011 0
14/11/2011 0
15/11/2011 0
18/11/2011 1
21/11/2011 4
5/12/2011 3
"
DF <- read.table(text = Lines, header = TRUE)
DF$date <- as.Date(DF$date, format = "%d/%m/%Y")

Answer 4

Podemos hacer esto simplemente aplicando la base de la siguiente manera:

Primero configure los datos (según la nota de @ g-grothendieck)

library(data.table)
Lines <- "
date value
1/11/2011 5
1/11/2011 4
1/11/2011 2
8/11/2011 1
13/11/2011 0
14/11/2011 0
15/11/2011 0
18/11/2011 1
21/11/2011 4
5/12/2011 3
"
DT <- as.data.table(read.table(text = Lines, header = TRUE))
DT$date <- as.Date(DF$date, format = "%d/%m/%Y")
DT$row <- 1:NROW(DF)
setkey(DT, row, date) #mark columns as sorted, for speed

Tenga en cuenta que agregué un vector a la tabla de datos que contiene el número de fila, para que podamos pasar el número de fila a la función de aplicación. También utilicé la tabla de datos para simplificar la sintaxis para el siguiente paso y para acelerar la función si se aplica a matrices grandes. Ahora, utilizamos aplicar de la siguiente manera:

roll.median.DT <- function(x){
this.date <- as.Date(x[1])
this.row <- as.numeric(x[3])
median(DT[row <= this.row & date >= (this.date-5)]$value) #NB DT is not defined within function, so it is found from parent scope
}
apply(DT, FUN=roll.median.DT, MARGIN = 1)
[1] 5.0 4.5 4.0 1.0 0.5 0.0 0.0 0.0 2.5 3.0