在 R 中使用 NA 在表中滚动加权总和

问题描述

我正在尝试在一个表中滚动加权总和，并且有一种涉及矩阵乘法的方法，但是当某些数据丢失时它会中断。

所以如果我使用

library(tidyverse)
mydata <- tibble(Country = c("Australia","Canada"),"1980" = c(1000,2000),"1981" = c(1100,2100),"1982" = c(1300,2300),"1983" = c(1200,2400),"1984" = c(1400,2200),"1985" = c(1500,2500))
weights <- c(3,4,6)

n0 <- ncol(mydata) - length(weights)
matweights <- matrix(rep(c(rep(0,n0),weights),n0)[-(1:n0)],ncol=n0) 
tibble(cbind(mydata[,1],as.matrix(mydata[,-1]) %*%  matweights))

我得到了我想要的

# A tibble: 2 x 5
  Country     `1`   `2`   `3`   `4`
  <chr>     <dbl> <dbl> <dbl> <dbl>
1 Australia 15200 15700 17100 18200
2 Canada    28200 29900 29700 31000

例如右上角的 18200 是 3*1200 + 4*1400 + 6*1500

但如果例如缺少其中一个值，请说 mydata[2,3] <- NA 然后我会得到

# A tibble: 2 x 5
  Country     `1`   `2`   `3`   `4`
  <chr>     <dbl> <dbl> <dbl> <dbl>
1 Australia 15200 15700 17100 18200
2 Canada       NA    NA    NA    NA

我想要的时候

# A tibble: 2 x 5
  Country     `1`   `2`   `3`   `4`
  <chr>     <dbl> <dbl> <dbl> <dbl>
1 Australia 15200 15700 17100 18200
2 Canada       NA    NA 29700 31000

我的矩阵方法的问题是 0 * NA 在我希望它是 NA 时给出 0。我知道有使用某种 apply 方法的解决方案，但我怀疑使用大表可能会更慢。

解决方法

使用 rollapply 我们有以下矩阵：

library(zoo)
t(rollapply(t(mydata[,-1]),3,function(x) sum(x * weights)))
##       [,1]  [,2]  [,3]  [,4]
## [1,] 15200 15700 17100 18200
## [2,]    NA    NA 29700 31000

线性filter选项：

t(apply(mydata[-1],1,stats::filter,filter=rev(weights),sides=1))
#     [,1] [,4]  [,5]  [,6]
#[1,]   NA   NA 15200 15700 17100 18200
#[2,]   NA   NA    NA    NA 29700 31000

我真的很喜欢 slider 的滑动函数——它非常灵活，并且有类似 purrr 的语法。在这里，slide_index_dbl() 将让我们滑动一个函数并使用另一个变量作为索引来决定窗口内的观察结果。

首先，重塑为长形式和组，然后是 mutate() 内的单个调用。 .before 此处指定要包含多少年； .complete 指定忽略部分窗口。

library(tidyverse)

out1 <- mydata %>% 
    gather(year,value,-Country,convert = TRUE) %>% 
    group_by(Country) %>% 
    mutate(
        value_3y = slider::slide_index_dbl(
            value,.i = year,.f = ~sum(.x * weights),.before = 2,.complete = TRUE
        )
    )

out1
#> # A tibble: 12 x 4
#> # Groups:   Country [2]
#>    Country    year value value_3y
#>    <chr>     <int> <dbl>    <dbl>
#>  1 Australia  1980  1000       NA
#>  2 Canada     1980  2000       NA
#>  3 Australia  1981  1100       NA
#>  4 Canada     1981  2100       NA
#>  5 Australia  1982  1300    15200
#>  6 Canada     1982  2300    28200
#>  7 Australia  1983  1200    15700
#>  8 Canada     1983  2400    29900
#>  9 Australia  1984  1400    17100
#> 10 Canada     1984  2200    29700
#> 11 Australia  1985  1500    18200
#> 12 Canada     1985  2500    31000

重塑为宽形式：

out1 %>% 
    select(-value) %>%
    drop_na() %>%    # omit to keep partial/empty years
    spread(year,value_3y)
#> # A tibble: 2 x 5
#> # Groups:   Country [2]
#>   Country   `1982` `1983` `1984` `1985`
#>   <chr>      <dbl>  <dbl>  <dbl>  <dbl>
#> 1 Australia  15200  15700  17100  18200
#> 2 Canada     28200  29900  29700  31000

如果数据包含 NA，代码的工作原理完全相同：

mydata[2,3] <- NA

out2 <- mydata %>% 
    gather(year,.complete = TRUE
        )
    )

out2
#> # A tibble: 12 x 4
#> # Groups:   Country [2]
#>    Country    year value value_3y
#>    <chr>     <int> <dbl>    <dbl>
#>  1 Australia  1980  1000       NA
#>  2 Canada     1980  2000       NA
#>  3 Australia  1981  1100       NA
#>  4 Canada     1981    NA       NA
#>  5 Australia  1982  1300    15200
#>  6 Canada     1982  2300       NA
#>  7 Australia  1983  1200    15700
#>  8 Canada     1983  2400       NA
#>  9 Australia  1984  1400    17100
#> 10 Canada     1984  2200    29700
#> 11 Australia  1985  1500    18200
#> 12 Canada     1985  2500    31000

out2 %>% 
    select(-value) %>%
    drop_na() %>% 
    spread(year,value_3y)
#> # A tibble: 2 x 5
#> # Groups:   Country [2]
#>   Country   `1982` `1983` `1984` `1985`
#>   <chr>      <dbl>  <dbl>  <dbl>  <dbl>
#> 1 Australia  15200  15700  17100  18200
#> 2 Canada        NA     NA  29700  31000

missing-data r r