Compute sum, subtraction, or sum and subtraction with missing values in R

user_7859377 0
Viewed 125

I wonder if there is an optimized way of summing up, subtracting or doing both when some values are missing.

For example, the following calculation can not be directly done because of missing.

library("data.table")
library("benchr")
library("glue")

dt <- data.table(A = c(NA,  2,  3,  4, NA),
                 B = c( 1, NA,  3, NA, NA),
                 C = c( 1,  2, NA, NA, NA))

dt[, SUM := A + B + C]
dt[, DIF := A - B - C]
dt[, MIX := A + B - C]

dt

    A  B  C SUM DIF MIX
1: NA  1  1  NA  NA  NA
2:  2 NA  2  NA  NA  NA
3:  3  3 NA  NA  NA  NA
4:  4 NA NA  NA  NA  NA
5: NA NA NA  NA  NA  NA

However, I wrote a function where I can accomplish the desired results, but I am not sure it is a optimized way of doing it since I had make an extra copy of the data so I don't change the original variables.

fun1<- function(tbl, expr_text, allowed = NULL) {
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  aux_tbl <- copy(tbl)
  if (is.null(allowed)) {
    setnafill(aux_tbl, "const", fill = 0)
  } else {
    setnafill(aux_tbl, "const", fill = 0, cols = allowed)
  }
  aux_tbl[, eval(rlang::parse_expr(expr_text))]
  expr_text <- glue::glue("{lhs} := fcase(rowSums(is.na(.SD)) < {length(rhs)}, {lhs})")
  tbl[, (lhs) := aux_tbl[, eval(rlang::parse_expr(expr_text)), .SDcols = rhs][[lhs]]]
}

dt <- data.table(A = c(NA,  2, -3,  4, NA),
                 B = c( 1, NA,  3, NA, NA),
                 C = c( 1,  2, NA, NA, NA))

fun1(tbl = dt, expr_text = "SUM := A + B + C")
fun1(tbl = dt, expr_text = "DIF := A - B - C")
fun1(tbl = dt, expr_text = "MIX := A + B - C")

dt

    A  B  C SUM DIF MIX
1: NA  1  1   2  -2   0
2:  2 NA  2   4   0   0
3: -3  3 NA   0  -6   0
4:  4 NA NA   4   4   4
5: NA NA NA   0   0   0

UPDATE

Actually, if all values are missing (line 5), then the result must be missing as well, not zero as in my first attempt. I re-wrote the function to fix this.

The expected result should be:

fun1 <- function(tbl, expr_text, allowed = NULL) {
  tbl <- copy(tbl)
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  aux_tbl <- copy(tbl)
  if (is.null(allowed)) {
    setnafill(aux_tbl, "const", fill = 0)
  } else {
    setnafill(aux_tbl, "const", fill = 0, cols = allowed)
  }
  aux_tbl[, eval(rlang::parse_expr(expr_text))]
  expr2 <- glue::glue("{lhs} := fcase(rowSums(is.na(.SD)) < {length(rhs)}, {lhs})")
  tbl[, (lhs) := aux_tbl[[lhs]]]
  tbl[, (lhs) := tbl[, eval(rlang::parse_expr(expr2)), .SDcols = rhs][[lhs]]][]
}

fun1(tbl = dt, expr_text = "MIX := A + B - C")

    A  B  C SUM DIF MIX
1: NA  1  1   2  -2   0
2:  2 NA  2   4   0   0
3: -3  3 NA   0  -6   0
4:  4 NA NA   4   4   4
5: NA NA NA  NA  NA  NA

Benchmark

library("data.table")
library("benchr")
library("glue")

n <- 100000
set.seed(12345)
dt <- data.table(A = sample(c(rnorm((1 - 0.10)*n), rep(NA_real_, 0.10*n))),
                 B = sample(c(rnorm((1 - 0.20)*n), rep(NA_real_, 0.20*n))),
                 C = sample(c(rnorm((1 - 0.35)*n), rep(NA_real_, 0.35*n))))

fun1 <- function(tbl, expr_text, allowed = NULL) {
  tbl <- copy(tbl)
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  aux_tbl <- copy(tbl)
  if (is.null(allowed)) {
    setnafill(aux_tbl, "const", fill = 0)
  } else {
    setnafill(aux_tbl, "const", fill = 0, cols = allowed)
  }
  aux_tbl[, eval(rlang::parse_expr(expr_text))]
  expr2 <- glue::glue("{lhs} := fcase(rowSums(is.na(.SD)) < {length(rhs)}, {lhs})")
  tbl[, (lhs) := aux_tbl[[lhs]]]
  tbl[, (lhs) := tbl[, eval(rlang::parse_expr(expr2)), .SDcols = rhs][[lhs]]][]
}

fun2 <- function(tbl, expr_text, allowed = NULL) {
  tbl <- copy(tbl)
  sgn <- trimws(unlist(strsplit(gsub(".*:=|\\+", "", expr_text), split = "[[:alnum:]]")))
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  expr1 <- glue::glue("{lhs} := mapply(sum, {paste0(sgn, rhs, collapse=',')}, na.rm =TRUE)")
  tbl[, eval(rlang::parse_expr(expr1))]
  expr2 <- glue::glue("{lhs} := fcase(rowSums(is.na(.SD)) < {length(rhs)}, {lhs})")
  tbl[, (lhs) := tbl[, eval(rlang::parse_expr(expr2)), .SDcols = rhs][[lhs]]][]
}

fun3 <- function(tbl, expr_text, allowed = NULL) {
  tbl <- copy(tbl)
  sgn <- paste0(trimws(unlist(strsplit(gsub(".*:=|\\+", "", expr_text), split = "[[:alnum:]]"))), 1, collapse = ", ")
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  expr1 <- glue::glue("{lhs} := rowSums(mapply('*', .SD, c({sgn})), na.rm =TRUE)")
  tbl[, eval(rlang::parse_expr(expr1)), .SDcols = rhs]
  expr2 <- glue::glue("{lhs} := fcase(rowSums(is.na(.SD)) < {length(rhs)}, {lhs})")
  tbl[, (lhs) := tbl[, eval(rlang::parse_expr(expr2)), .SDcols = rhs][[lhs]]][]
}

fun4 <- function(tbl, expr_text, allowed = NULL) {
  tbl <- copy(tbl)
  rhs <- setdiff(trimws(unlist(strsplit(gsub(".*:=", "", expr_text), split = "[[:punct:]]"))), allowed)
  lhs <- trimws(unlist(strsplit(gsub(":=.*", "", expr_text), split = "[[:punct:]]")))
  aux_tbl <- copy(tbl)
  if (is.null(allowed)) {
    setnafill(aux_tbl, "const", fill = 0)
  } else {
    setnafill(aux_tbl, "const", fill = 0, cols = allowed)
  }
  is_missing <- tbl[, NA ^ (rowSums(!is.na(.SD)) == 0), .SDcols = rhs]
  expr_text <- paste0(gsub(":=", ":= (", expr_text), ") * is_missing")
  aux_tbl[, eval(rlang::parse_expr(expr_text))]
  tbl[, (lhs) := aux_tbl[[lhs]]][]
}

res <- benchr::benchmark(
  fun1 = fun1(tbl = dt, expr_text = "MIX := A + B + C"),
  fun2 = fun2(tbl = dt, expr_text = "MIX := A + B + C"),
  fun3 = fun3(tbl = dt, expr_text = "MIX := A + B + C"),
  fun4 = fun4(tbl = dt, expr_text = "MIX := A + B + C")
)

print(res, order = "median")

Benchmark summary:
  Time units : milliseconds 
expr n.eval    min  lw.qu median   mean up.qu   max total relative
fun4    100   6.42   6.74   6.88   9.27  11.6  25.5   927     1.00
fun1    100   6.76   7.04   7.33  14.70  14.2 128.0  1470     1.07
fun3    100   8.76   9.14  13.10  16.40  18.1 101.0  1640     1.91
fun2    100 146.00 181.00 206.00 208.00 230.0 298.0 20800    30.00

I wrote some of the answers as functions to benchmark them. I've created also an additional fun4 which is slightly faster than the original fun1.

Boxplot of Benchmark

I was thinking about writing it using Rcpp, but I am not sure if it would make it better.

Would anyone know a better approach or has a suggestion?

Thank you.

data.table r
3 Answers

By using mapply

library(data.table)
dt <- data.table(A = c(1,  2,  3,  4, NA),
                 B = c( 1, NA,  3, NA, NA),
                 C = c( 1,  2, NA, NA, NA))

dt[, SUM := mapply(sum, A,B,C, na.rm =TRUE)]
dt[, DIF := mapply(sum, A,-B,-C, na.rm =TRUE)]
dt[, MIX := mapply(sum, A,B,-C, na.rm =TRUE)]

    A  B  C SUM DIF MIX
1:  1  1  1   3  -1   1
2:  2 NA  2   4   0   0
3:  3  3 NA   6   0   6
4:  4 NA NA   4   4   4
5: NA NA NA   0   0   0
user_140616030

A possible improvement of @Pete Kittinuns suggestion, with rowSums. I have not benchmarked it, but this solution is more general and could be faster (rowSums is lightning-fast).

dt <- data.table(A = c(NA,  2, -3,  4, NA),
                 B = c( 1, NA,  3, NA, NA),
                 C = c( 1,  2, NA, NA, NA))

dt[, SUM := rowSums(dt, na.rm =TRUE)]
dt[, DIF := rowSums(cbind(dt[,A], dt[,B:C]*-1), na.rm = TRUE)]
dt[, MIX := rowSums(cbind(dt[,A:B], dt[,C]*-1), na.rm=TRUE)]

> dt
    A  B  C SUM DIF MIX
1: NA  1  1   2  -2   0
2:  2 NA  2   4   0   0
3: -3  3 NA   0  -6   0
4:  4 NA NA   4   4   4
5: NA NA NA   0   0   0
user_139723330

You can try the following data.table option

dt[, c(.SD, .(
  SUM = rowSums(.SD, na.rm = TRUE),
  DIF = rowSums(mapply("*", .SD, c(1, -1, -1)), na.rm = TRUE),
  MIX = rowSums(mapply("*", .SD, c(1, 1, -1)), na.rm = TRUE)
))]

which gives

    A  B  C SUM DIF MIX
1: NA  1  1   2  -2   0
2:  2 NA  2   4   0   0
3:  3  3 NA   6   0   6
4:  4 NA NA   4   4   4
5: NA NA NA   0   0   0
user_121587570
Related