Riempire i valori NA con il valore della riga finale per un tasso di crescita?

Question

Quale sarebbe un buon modo per popolare i valori NA con il valore precedente, (1+growth)?

df <- data.frame(year=0:6, 
       price1=c(1.1, 2.1, 3.2, 4.8, NA, NA, NA), 
       price2=c(1.1, 2.1, 3.2, NA, NA, NA, NA)) 
growth <- .02 

In questo caso, vorrei i valori mancanti in price1 da riempire con 4.8*1.02, 4.8*1.02^2 e 4.8*1.02^3. Allo stesso modo, vorrei che i valori mancanti in price2 venissero riempiti con 3.2*1.02, 3.2*1.02^2, 3.2*1.02^3 e 3.2*1.02^4.

Ho provato questo, ma penso che deve essere impostato per ripetere in qualche modo (apply?):

library(dplyr) 
df %>% mutate(price1=ifelse(is.na(price1), 
      lag(price1)*(1+growth), price1)) 

Non sto usando dplyr per altri scopi (ancora), quindi qualcosa dalla base R o plyr o simili sarebbe apprezzato.

Answer 1

Sembra dplyr non può gestire l'accesso valori del ritardo di nuova assegnazione. Ecco una soluzione che dovrebbe funzionare anche se gli NA si trovano nel mezzo di una colonna.

df <- apply(
    df, 2, function(x){ 
    if(sum(is.na(x)) == 0){return(x)} 
    ## updated with optimized portion from @josilber 
    r <- rle(is.na(x)) 
    na.loc <- which(r$values) 
    b <- rep(cumsum(r$lengths)[na.loc-1], r$lengths[na.loc]) 
    lastValIs <- 1:length(x) 
    lastValI[is.na(x)] <- b 
    x[is.na(x)] <- 
     sapply(which(is.na(x)), function(i){ 
     return(x[lastValIs[i]]*(1 + growth)^(i - lastValIs[i])) 
     }) 
    return(x) 
    }) 

Answer 2

Si può provare tale funzione

test <- function(x,n) { 
     if (!is.na(df[x,n])) return (df[x,n]) 
     else   return (test(x-1,n)*(1+growth)) 
    } 


a=1:nrow(df) 


lapply(a, FUN=function(i) test(i,2)) 

unlist(lapply(a, FUN=function(i) test(i,2))) 

[1] 1,100000 2,100000 3,200000 4,800000 4,896000 4,993920 5,093798

Answer 3

Supponendo AN solo finali:

NAgrow <- function(x,growth=0.02) { 
    isna <- is.na(x) 
    lastval <- tail(x[!isna],1) 
    x[isna] <- lastval*(1+growth)^seq(sum(isna)) 
    return(x) 
} 

se ci sono interni NA valori così questo sarebbe un po 'più complicato.

Applica a tutte le colonne ad eccezione del primo:

df[-1] <- lapply(df[-1],NAgrow) 

## year price1 price2 
## 1 0 1.100000 1.100000 
## 2 1 2.100000 2.100000 
## 3 2 3.200000 3.200000 
## 4 3 4.800000 3.264000 
## 5 4 4.896000 3.329280 
## 6 5 4.993920 3.395866 
## 7 6 5.093798 3.463783 

Answer 4

la seguente soluzione basata su rle opere con NA di qualsiasi posizione e non si basa su loop per riempire i valori mancanti:

NAgrow.rle <- function(x) { 
    if (is.na(x[1])) stop("Can't have NA at beginning") 
    r <- rle(is.na(x)) 
    na.loc <- which(r$values) 
    b <- rep(cumsum(r$lengths)[na.loc-1], r$lengths[na.loc]) 
    x[is.na(x)] <- ave(x[b], b, FUN=function(y) y[1]*(1+growth)^seq_along(y)) 
    x 
} 
df[,-1] <- lapply(df[,-1], NAgrow.rle) 
# year price1 price2 
# 1 0 1.100000 1.100000 
# 2 1 2.100000 2.100000 
# 3 2 3.200000 3.200000 
# 4 3 4.800000 3.264000 
# 5 4 4.896000 3.329280 
# 6 5 4.993920 3.395866 
# 7 6 5.093798 3.463783 

Passerò in due ulteriori soluzioni utilizzando per i loop , uno in base di R ed una in Rcpp:

NAgrow.for <- function(x) { 
    for (i in which(is.na(x))) { 
    x[i] <- x[i-1] * (1+growth) 
    } 
    x 
} 

library(Rcpp) 
cppFunction(
"NumericVector NAgrowRcpp(NumericVector x, double growth) { 
    const int n = x.size(); 
    NumericVector y(x); 
    for (int i=1; i < n; ++i) { 
    if (R_IsNA(x[i])) { 
     y[i] = (1.0 + growth) * y[i-1]; 
    } 
    } 
    return y; 
}") 

Le soluzioni basate su rle (crimson e josilber.rle) prendere circa il doppio purché la soluzione semplice basata su un ciclo for (josilber.for), e come previsto, la soluzione Rcpp è la più veloce, in esecuzione in circa 0,002 secondi.

set.seed(144) 
big.df <- data.frame(ID=1:100000, 
        price1=sample(c(1:10, NA), 100000, replace=TRUE), 
        price2=sample(c(1:10, NA), 100000, replace=TRUE)) 
crimson <- function(df) apply(df[,-1], 2, function(x){ 
    if(sum(is.na(x)) == 0){return(x)} 
    ## updated with optimized portion from @josilber 
    r <- rle(is.na(x)) 
    na.loc <- which(r$values) 
    b <- rep(cumsum(r$lengths)[na.loc-1], r$lengths[na.loc]) 
    lastValIs <- 1:length(x) 
    lastValIs[is.na(x)] <- b 
    x[is.na(x)] <- 
    sapply(which(is.na(x)), function(i){ 
     return(x[lastValIs[i]]*(1 + growth)^(i - lastValIs[i])) 
    }) 
    return(x) 
}) 
ggrothendieck <- function(df) { 
    growthfun <- function(x, y) if (is.na(y)) (1+growth)*x else y 
    lapply(df[,-1], Reduce, f = growthfun, acc = TRUE) 
} 
josilber.rle <- function(df) lapply(df[,-1], NAgrow.rle) 
josilber.for <- function(df) lapply(df[,-1], NAgrow.for) 
josilber.rcpp <- function(df) lapply(df[,-1], NAgrowRcpp, growth=growth) 
library(microbenchmark) 
microbenchmark(crimson(big.df), ggrothendieck(big.df), josilber.rle(big.df), josilber.for(big.df), josilber.rcpp(big.df)) 
# Unit: milliseconds 
#     expr  min   lq  mean  median   uq   max neval 
#  crimson(big.df) 98.447546 131.063713 161.494366 152.477661 183.175840 379.643222 100 
# ggrothendieck(big.df) 437.015693 667.760401 822.530745 817.864707 925.974019 1607.352929 100 
# josilber.rle(big.df) 59.678527 115.220519 132.874030 127.476340 151.665657 262.003756 100 
# josilber.for(big.df) 21.076516 57.479169 73.860913 72.959536 84.846912 178.412591 100 
# josilber.rcpp(big.df) 1.248793 1.894723 2.373469 2.190545 2.697246 5.646878 100 

Answer 5

Una soluzione di base R compatto può essere ottenuta utilizzando Reduce:

growthfun <- function(x, y) if (is.na(y)) (1+growth)*x else y 
replace(df, TRUE, lapply(df, Reduce, f = growthfun, acc = TRUE)) 

dando:

year price1 price2 
1 0 1.100000 1.100000 
2 1 2.100000 2.100000 
3 2 3.200000 3.200000 
4 3 4.800000 3.264000 
5 4 4.896000 3.329280 
6 5 4.993920 3.395866 
7 6 5.093798 3.463783 

Nota: I dati in questione non ha non trascinamento NA valori ma se ce ne fossero alcuni, potremmo usare lo na.fill dallo zoo per sostituire prima gli ID finali con un valore speciale, come Na N, e cercare invece di NA:

library(zoo) 

DF <- as.data.frame(na.fill(df, c(NA, NA, NaN))) 
growthfun <- function(x, y) if (is.nan(y)) (1+growth)*x else y 
replace(DF, TRUE, lapply(DF, Reduce, f = growthfun, acc = TRUE))