r - 使用 dplyr (或其他)将 R 代码简化为 rowSums 而忽略 NA，除非全部为 NA

Question

我最初在 this questions 的帮助下解决了我的 NA 问题.但是，我想简化我的代码。过去，我很享受 dplyr 的方式帮助我简化了 R 代码。

下面是一个最小的工作示例，说明了我当前的解决方案以及我在 dplyr 中所处的位置。

我有这样的数据，

dta <- data.frame(foo=c(1,NA,3,4), fooZ=c(4,NA,5,NA), fooQ2=c(7,0,9,NA))

我需要总结很多行，使用 0 作为我 sum 的 a 值 并为所有行保留 NA 不适用。像这样，

dta$sum1 <- rowSums(dta[, c('fooZ', 'fooQ2') ], na.rm=TRUE) * ifelse(
      rowSums(is.na(dta[, c('fooZ', 'fooQ2') ])) == 
               ncol(dta[, c('fooZ', 'fooQ2') ]), NA, 1)
dta
# >   foo fooZ fooQ2 sum1
# > 1   1    4     7   11
# > 2  NA   NA     0    0
# > 3   3    5     9   14
# > 4   4   NA    NA   NA

这可以解决问题并创建 sum1，但我必须重复对数据的引用 3 次。我可以用一些方便的方式简化它吗？我使用 dplyr 制作了以下代码，但也许有更好的方法来汇总行；同时为具有所有 NA 的行保留 NA，忽略具有一个或多个值的行中的 NA，并将值视为 0 '总结'？

# install.packages(c("dplyr", "ggplot2"), dependencies = TRUE)
require(dplyr)
dta$sum2 = dta %>% select(fooZ, fooQ2) %>% rowSums(., na.rm = TRUE)
dta
# >   foo fooZ fooQ2 sum1 sum2
# > 1   1    4     7   11   11
# > 2  NA   NA     0    0    0
# > 3   3    5     9   14   14
# > 4   4   NA    NA   NA    0

这会创建 sum2，但如果 na.rm = TRUE 则生成 0，如果 na 则生成太多 NA。 rm = F。

16 22:18:33Z 更新

我对不同的答案做了这个有点精细的 micro-基准比较。请不要急于优化任何功能。编写 R 函数不是我的力量。无论如何，

set.seed(667)
n <- 1e5+22
dta <- data.frame(
  foo = sample(c(1:10, NA), n, replace = TRUE),
  fooZ = sample(c(1:10, NA), n, replace = TRUE),
  fooQ2 = sample(c(1:10, NA), n, replace = TRUE))

slice <- c(902:907,979:984)
dta[slice,]
#>     foo fooZ fooQ2
#> 902  10    7     2
#> 903  10   10     9
#> 904  NA   NA     8
#> 905   6    4     3
#> 906   8    9    10
#> 907   1    5    NA
#> 979  NA    1     1
#> 980  10    2    NA
#> 981   7   NA    NA
#> 982   3    7     7
#> 983  NA    9     6
#> 984   7   10     7


# `baseline' solution
baseline <- function(z, ...) {W  <- z[, c(...)]; W <- rowSums(W, na.rm=TRUE) * ifelse(rowSums(is.na(W)) == ncol(W), NA, 1); W}

# install.packages(c("dplyr", "ggplot2"), dependencies = TRUE)
require(dplyr)
# G. G.Gro's dplyr solution
G.Gro_dplyr1 <- function(z, ...) z %>% mutate(sum2 = select(., ...) %>% { rowSums(., na.rm = TRUE) + ifelse(apply(is.na(.), 1, all), NA, 0) })

# G. G.Gro's Variation 1a solution
G.Gro_dplyr1a <- function(z, ...) z %>% mutate(sum2 = select(., fooZ, fooQ2) %>% apply(1, . %>% { sum(., na.rm = TRUE) + if (all(is.na(.))) NA else 0}))

# G. G.Gro's base solution
G.Gro_base <- function(z, ...) {W  <- z[, c(...)]; S = {X <- dta[, c("fooZ", "fooQ2")]; rowSums(X, na.rm = TRUE) + ifelse(apply(is.na(X), 1, all), NA, 0)}; S}

# Thierry's solution
Thierry_my_sum <- function(z, ...){z <- select(z, ...); sums <- rowSums(z, na.rm = TRUE); sums[apply(is.na(z), 1, all)] <- NA; sums}

# lmo's solution
lmo <- function(z, ...) {W  <- z[, c(...)]; rowSums(W, na.rm=TRUE) * (NA^(rowSums(is.na(W)) == ncol(W)))}

# Benjamin's solution
Benjamin <- function(..., na.rm = FALSE, all.na = NA){v <- list(...); all_na <- lapply(v, is.na); all_na <- Reduce(`&`, all_na); all_na; if (na.rm){v <- lapply(v, function(x) {x[is.na(x)] <- 0; x}); }; v <- Reduce(`+`, v); v[all_na] <- all.na; v;}

# Aramis7d's solution
Aramis7d <- function(z, ...) {z %>% select(...) %>% mutate(sum = rowSums(., na.rm=TRUE)) %>% mutate(s2 = rowSums(is.na(.))) %>% mutate(sum = if_else(s2 < 2, sum, as.double(NA))) %>%  select(sum) }

# Fail's solution combining from all
Fail <- function(z, ...){z <- select(z, ...); zTF <- rowMeans(is.na(z)) == 1; replace(rowSums(z, na.rm = TRUE), zTF, NA)}

# install.packages("microbenchmark", dependencies = TRUE)
require(microbenchmark)

# run test
res <- microbenchmark(
baseline(dta, c("fooZ", "fooQ2")),
Thierry_my_sum(dta, fooZ, fooQ2),
G.Gro_dplyr1(dta, fooZ, fooQ2)[,ncol(dta)+1],
G.Gro_dplyr1a(dta, fooZ, fooQ2)[, ncol(dta) + 1],
G.Gro_base(dta, c("fooZ", "fooQ2")),
(dta %>% mutate(sum99 = Benjamin(fooZ, fooQ2, na.rm = TRUE)))[,ncol(dta)+1],
lmo(dta, c("fooZ", "fooQ2")),
Aramis7d(dta, fooZ, fooQ2)[,1],
Fail(dta, fooZ, fooQ2),
 times = 25)

# clean up
levels(res[[1]]) <- c('baseline', 'Thierry', 'G.Gro1', 'G.Gro1a', 'G.Gro2', 'Benjamin', 'lmo', 'Aramis7d', 'Fail')

## Print results:
print(res)

 print(res)
#> Unit: milliseconds
#>      expr        min         lq        mean     median          uq        max neval cld
#>  baseline  12.729803  15.691060   31.141114  23.299101   48.694436   72.83702    25   a  
#>   Thierry 215.541035 241.795764  298.319826 263.822553  363.066476  494.90875    25   b 
#>    G.Gro1 226.761181 242.617099  295.413437 264.911513  307.339115  591.28424    25   b 
#>   G.Gro1a 935.176542 985.329298 1088.300741 997.788858 1030.085839 1736.51506    25   c
#>    G.Gro2 219.650080 227.464694  292.898566 246.188189  320.789036  505.08154    25   b 
#>  Benjamin   6.227054   9.327364   15.583907  11.230079   14.345366   55.44653    25   a  
#>       lmo   4.138434   5.970850    9.329506   6.851132    8.406799   39.40295    25   a  
#>  Aramis7d  33.966101  38.737671   60.777304  66.663967   72.686939  100.72799    25   a  
#>      Fail  11.464254  13.932386   20.476011  14.865245   25.156740   58.37730    25   a  

### Plot results:
boxplot(res)

Answer 1

这是一个使用 NA 取幂的基本 R 技巧:

rowSums(dta[-1], na.rm=TRUE) * (NA^(rowSums(is.na(dta[-1])) == ncol(dta[-1])))
[1] 11  8 14 NA

任何数字的 0 次方都是 1，因此任何包含非 NA 值的行在第二项中返回 1。否则，返回 NA。

这假设您只想考虑除第一个变量之外的变量。

将 OP 对上述代码的改进与一个额外的步骤相结合，我们可以提高效率

rowSumsNA <- function(dat, ...) {
    W <- data.matrix(dat[...])
    rowSums(W, na.rm=TRUE) * (NA^(rowSums(is.na(W)) == ncol(W)))
}

大部分改进在于 OP 在计算之前存储子集 data.frame 的方法(在我的机器上为 127 毫秒对 84 毫秒)，但可以通过将该 data.frame 转换为矩阵先验来获得轻微的额外改进调用 rowSums(在我的机器上是 84 毫秒 vs 77 毫秒)。