R - Расчет различий по группам для всех разрезов данных

Question

У меня есть набор данных с несколькими атрибутами и значением.

Ввод (образец)

  GRP CAT TYP  VAL
    X   H   5 0.76
    X   A   2 0.34
    X   D   3 0.70
    X   I   3 0.33
    X   F   4 0.80
    X   E   1 0.39

Я хочу:

1. Определить все комбинации CAT и TYP
2. Для каждой комбинации рассчитать среднее значение при удалении комбинации
3. Вернуть окончательную таблицу различий

Финальная таблица (образец)

   CAT TYP    DIFF
1 <NA>  NA 0.04000
2    H  NA 0.03206

Строка 1 означает, что если записи не удаляются, разница между средним значением GRP='X' и GRP='Y' составляет 0,04.Строка 2 означает, что если удаляются записи с CAT='H', разница составляет 0,032.

У меня есть рабочий код, но я хочу сделать его быстрее.Я открыт для ваших предложений.

Рабочий код

library(dplyr)

set.seed(777)

# build example data frame
df <- data.frame(GRP = c(rep('X',25),rep('Y',25)),
                 CAT = sample(LETTERS[1:10], 50, T),
                 TYP = sample(1:5, 50, T),
                 VAL = sample(1:100, 50, T)/100,
                 stringsAsFactors = F)

# table of all combinations of CAT and TYP
splits <- expand.grid(lapply(df[,-c(1,4)], function(x) c(NA, unique(x))), stringsAsFactors = F)

# null data frame to store results
ans <- data.frame(CAT = character(),
                  TYP = integer(),
                  DIFF = numeric(),
                  stringsAsFactors = F)

# loop through each combination and calculate the difference between group X and Y
for(i in 1:nrow(splits)) {

  split.i <- splits[i,]

  # determine non-na columns
  by.cols <- colnames(split.i)[unlist(lapply(split.i, function(x) !all(is.na(x))))]

  # anti-join to remove records that match `split.i`
  if(length(by.cols) > 0){
    df.i <- df %>%
      anti_join(split.i, by = by.cols)
  } else {
    df.i <- df
  }

  # calculate average by group
  df.i <- df.i %>%
    group_by(GRP) %>%
    summarize(VAL_MEAN = mean(VAL))

  # calculate difference of averages
  DIFF <- df.i[,2] %>%
    as.matrix() %>%
    diff() %>%
    as.numeric()

  ans.tmp <- cbind(split.i, DIFF)

  # bind to final data frame
  ans <- bind_rows(ans, ans.tmp)

}
return(ans)

Результаты скорости

> system.time(fcnDiffCalc())
   user  system elapsed 
   0.30    0.02    0.31 

Answer 1

Рекомендуется присвоить столбец DIFF с sapply вместо увеличения фрейма данных в цикле, чтобы избежать повторного копирования в памяти:

fcnDiffCalc2 <- function() {
  # table of all combinations of CAT and TYP
  splits <- data.frame(expand.grid(lapply(df[,-c(1,4)], function(x) c(NA, unique(x))), 
                       stringsAsFactors = F))

  # loop through each combination and calculate the difference between group X and Y
  splits$DIFF <- sapply(1:nrow(splits), function(i) {

    split.i <- splits[i,]

    # determine non-na columns
    by.cols <- colnames(split.i)[unlist(lapply(split.i, function(x) !all(is.na(x))))]

    # anti-join to remove records that match `split.i`
    df.i <- tryCatch(df %>%
        anti_join(split.i, by = by.cols), error = function(e) df)

    # calculate average by group
    df.i <- df.i %>%
      group_by(GRP) %>%
      summarize(VAL_MEAN = mean(VAL))

    # calculate difference of averages
    DIFF <- df.i[,2] %>%
      as.matrix() %>%
      diff() %>%
      as.numeric()
  })

  return(splits)
}

Еще лучше избегать циклав expand.grid используйте vapply сверх sapply (даже unlist + lapply = sapply или vapply), определяющие структуру результата, и избегайте конвейеров в цикле, чтобы вернуться к базовым R aggregate:

fcnDiffCalc3 <- function() {
  # table of all combinations of CAT and TYP
  splits <- data.frame(expand.grid(CAT = c(NA, unique(df$CAT)), TYP = c(NA, unique(df$TYP)),
                                   stringsAsFactors = FALSE))

  # loop through each combination and calculate the difference between group X and Y
  splits$DIFF <- vapply(1:nrow(splits), function(i) {

    split.i <- splits[i,]

    # determine non-na columns
    by.cols <- colnames(split.i)[vapply(split.i, function(x) !all(is.na(x)), logical(1))]

    # anti-join to remove records that match `split.i`
    df.i <- tryCatch(anti_join(df, split.i, by = by.cols), error = function(e) df)

    # calculate average by group
    df.i <- aggregate(VAL ~ GRP, df.i, mean)

    # calculate difference of averages
    diff(df.i$VAL)

  }, numeric(1))

  return(splits)
}

Выход

df_op <- fcnDiffCalc() 
df_new <- fcnDiffCalc2()
df_new2 <- fcnDiffCalc3()

identical(df_op, df_new)
# [1] TRUE
identical(df_op, df_new2)
# [1] TRUE

library(microbenchmark)

microbenchmark(fcnDiffCalc(), fcnDiffCalc2(), fcnDiffCalc3())

# Unit: milliseconds
#            expr      min       lq     mean   median       uq      max neval
#   fcnDiffCalc() 128.1442 140.1946 152.0703 154.3662 159.6809 180.5960   100
#  fcnDiffCalc2() 115.4415 126.6108 138.0991 137.4108 145.2452 266.3297   100
#  fcnDiffCalc3() 107.6847 116.9920 126.9131 126.0414 133.3887 227.2758   100