Вычислите сумму, вычитание или сумму и вычитание с пропущенными значениями в R

ProgramBox

Вычислите сумму, вычитание или сумму и вычитание с пропущенными значениями в R

Post author:admin
Запись опубликована:19 января, 2022
Post category:Вопросы по программированию

#r #data.table

Вопрос:

Интересно, существует ли оптимизированный способ суммирования, вычитания или выполнения и того, и другого, когда некоторые значения отсутствуют.

Например, следующий расчет не может быть выполнен напрямую из-за отсутствия.

 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

Тем не менее, я написал функцию, в которой я могу достичь желаемых результатов, но я не уверен, что это оптимизированный способ сделать это, так как я сделал дополнительную копию данных, чтобы не изменять исходные переменные.

 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

Обновить

На самом деле, если все значения отсутствуют (строка 5), то результат также должен отсутствовать, а не быть нулевым, как в моей первой попытке. Я переписал функцию, чтобы исправить это.

Ожидаемый результат должен быть:

 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

Показатель

 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

Я написал некоторые ответы в качестве функций для их сравнения. Я также создал дополнительный fun4, который немного быстрее, чем оригинальный fun1.

Я думал о том, чтобы написать его с помощью Rcpp, но я не уверен, что это сделает его лучше.

Кто-нибудь знает лучший подход или у кого есть предложения?

Спасибо.

Ответ №1:

С помощью 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

1. Возможно, вам захочется использовать векторизованные или сверхбыстрые функции, поскольку производительность является проблемой. Возможно dt[, SUM := rowSums(dt, na.rm =TRUE)] , это быстрее, чем ваш оригинал dt[, SUM := mapply(sum, A,B,C, na.rm =TRUE)] , например

2. Очень хорошее предложение. Могу я спросить, как это может быть реализовано в строке DIF и MIX?

3. Смотрите мой ответ ниже

Ответ №2:

Возможное улучшение предложения @Pete Kittinuns с суммами строк. Я не проводил сравнительный анализ, но это решение является более общим и может быть быстрее (rowSums молниеносен).

 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

Ответ №3:

Вы можете попробовать следующий data.table вариант

 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)
))]

что дает

     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

1. Это то, что я искал, это имеет некоторое значительное улучшение по сравнению с моим ответом

2. Мне было интересно, эффективен ли этот «»сопоставление(«*»)%>%сумм строк»», хотя

3. @GuedesBF Я думаю, что ваш код так же эффективен, как и этот, с точки зрения скорости.

4. Не могли бы вы любезно объяснить, почему rowSums(mapply("*", .SD, c(1, -1, -1)), na.rm = TRUE) это быстрее, чем просто использовать mapply(sum, A,-B,-C, na.rm =TRUE) . Спасибо

5. @PeteKittinun Я не проверял скорость. Я не уверен, что mapply это быстрее ….

Метки: Вычислите сумму, вычитание или сумму и вычитание с пропущенными значениями в R