statement - ¿Cómo optimizar el siguiente código con while-loop anidado? ¿Multicore una opción?

if else r studio

Question

Estoy teniendo un desafío con un código que lleva mucho tiempo ejecutar y me pregunto cuáles son los trucos clave para optimizar el tiempo de ejecución de este código. Tengo que admitir que el data.frame de entrada es significativo (140,000 filas) y que el data.frame de salida es de aproximadamente 220,000 filas.

Una muestra de la entrada data.frame:

head(extremes)
X_BusinessIDDescription min max month
ID105 2007-12-01 2008-06-01 2007-12-01
ID206 2007-12-01 2009-07-01 2007-12-01
ID204 2007-12-01 2008-02-01 2007-12-01
ID785 2008-07-01 2010-08-01 2008-07-01
ID125 2007-11-01 2008-07-01 2007-11-01
ID107 2007-11-01 2011-06-01 2007-11-01

El data.frame que se extenderá con el bucle. El data.frame se inicia para obtener la estructura en su lugar.

output <- extremes[1,]
output
X_BusinessIDDescription min max month
ID105 2007-12-01 2008-06-01 2007-12-01

Otros valores

IDcounter <- 1
IDmax <- nrow(extremes)
linecounter <- 1

El while-loop me gustaría optimizar:

while (IDcounter <= IDmax){
start <- extremes$min[IDcounter]
end <- extremes$max[IDcounter] # add three months
while(start <= end){
output[linecounter,] <- extremes[IDcounter,]
output$month[linecounter] <- start
linecounter <- linecounter+1
start <- seq(start, by ="month", length=2)[2]
}
IDcounter <- IDcounter + 1
}

Para un pequeño número de filas, este código se ejecuta bastante rápido, pero parece que se está desacelerando a medida que se extiende la salida.

El resultado se ve así:

head(output)
X_BusinessIDDescription min max month
ID105 2007-12-01 2008-06-01 2007-12-01
ID105 2007-12-01 2008-06-01 2008-01-01
ID105 2007-12-01 2008-06-01 2008-02-01
ID105 2007-12-01 2008-06-01 2008-03-01
ID105 2007-12-01 2008-06-01 2008-04-01
ID105 2007-12-01 2008-06-01 2008-05-01

Por cada mes en el intervalo entre min y max en el archivo extremo se crea una fila.

También me interesaría saber cómo puedo hacer para que este código pueda tener en cuenta los múltiples núcleos de recursos informáticos disponibles. De acuerdo, admito que esto no es realmente una optimización, pero reducirá el tiempo de ejecución, que también es importante.

Jochem

Answer 1

Como ya se mencionó en @CarlWitthoft, debe reconsiderar su estructura de datos debido a la cantidad de datos duplicados.

Aquí encontrará un enfoque vectorizado simple:

 ## create all possible ranges of months
ranges <- mapply(function(mi, ma) {seq(from=mi, to=ma, by="month")}, mi=extremes$min, ma=extremes$max)
## how many months per ID?
n <- unlist(lapply(ranges, length))
## create new data.frame
output <- data.frame(X_BusinessIDDescription=rep(extremes$X_BusinessIDDescription, n),
min=rep(extremes$min, n),
max=rep(extremes$max, n),
month=as.Date(unlist(ranges), origin="1970-01-01"), stringsAsFactors=FALSE)

Comparación con su enfoque:

extremes <- data.frame(X_BusinessIDDescription=c("ID105", "ID206", "ID204", "ID785", "ID125", "ID107"),
min=as.Date(c("2007-12-01", "2007-12-01", "2007-12-01", "2008-07-01", "2007-11-01", "2007-11-01")),
max=as.Date(c("2008-06-01", "2009-07-01", "2008-02-01", "2010-08-01", "2008-07-01", "2011-06-01")),
month=as.Date(c("2007-12-01", "2007-12-01", "2007-12-01", "2008-07-01", "2007-11-01", "2007-11-01")),
stringsAsFactors=FALSE)
approachWhile <- function(extremes) {
output <- data.frame(X_BusinessIDDescription=NA, min=as.Date("1970-01-01"), max=as.Date("1970-01-01"), month=as.Date("1970-01-01"), stringsAsFactors=FALSE)
IDcounter <- 1
IDmax <- nrow(extremes)
linecounter <- 1
while (IDcounter <= IDmax){
start <- extremes$min[IDcounter]
end <- extremes$max[IDcounter] # add three months
while(start <= end){
output[linecounter,] <- extremes[IDcounter,]
output$month[linecounter] <- start
linecounter <- linecounter+1
start <- seq(start, by ="month", length=2)[2]
}
IDcounter <- IDcounter + 1
}
return(output)
}
approachMapply <- function(extremes) {
ranges <- mapply(function(mi, ma) {seq(from=mi, to=ma, by="month")}, mi=extremes$min, ma=extremes$max)
n <- unlist(lapply(ranges, length))
output <- data.frame(X_BusinessIDDescription=rep(extremes$X_BusinessIDDescription, n),
min=rep(extremes$min, n),
max=rep(extremes$max, n),
month=as.Date(unlist(ranges), origin="1970-01-01"), stringsAsFactors=FALSE)
return(output)
}
identical(approachWhile(extremes), approachMapply(extremes)) ## TRUE
library("rbenchmark")
benchmark(approachWhile(extremes), approachMapply(extremes), order="relative")
# test replications elapsed relative user.self sys.self
#2 approachMapply(extremes) 100 0.176 1.00 0.172 0.000
#1 approachWhile(extremes) 100 6.102 34.67 6.077 0.008