Самый быстрый способ фильтрации содержимого столбца списка data.frame в R / Rcpp

У меня есть data.frame:

df <- structure(list(id = 1:3, vars = list("a", c("a", "b", "c"), c("b", 
"c"))), .Names = c("id", "vars"), row.names = c(NA, -3L), class = "data.frame")

со столбцом списка (каждый с символьным вектором):

> str(df)
'data.frame':   3 obs. of  2 variables:
     $ id  : int  1 2 3
     $ vars:List of 3
      ..$ : chr "a"
      ..$ : chr  "a" "b" "c"
      ..$ : chr  "b" "c"

Я хочу отфильтровать data.frame в соответствии с setdiff(vars,remove_this)

library(dplyr)
library(tidyr)
res <- df %>% mutate(vars = lapply(df$vars, setdiff, "a"))

который получает меня это:

   > res
      id vars
    1  1     
    2  2 b, c
    3  3 b, c

Но чтобы бросить character(0) ВАРС я должен сделать что-то вроде:

res %>% unnest(vars) # and then do the equivalent of nest(vars) again after...

Фактические наборы данных:

  • 560K строк и 3800K строк, которые также имеют еще 10 столбцов (для переноса).

(это довольно медленно, что приводит к вопросу...)

Какой самый быстрый способ сделать это в R?

  • Есть ли dplyr/ data.table/ другой более быстрый метод?
  • Как это сделать с Rcpp?

UPDATE / EXTENSION:

  • можно ли выполнить изменение столбца вместо копирования lapply(vars,setdiff(... результат?

  • какой самый эффективный способ отфильтровать vars == character(0) если это должен быть отдельный шаг.

Источник

3 ответа

Решение

Оставляя в стороне любые алгоритмические улучшения, аналогичные data.table Решение автоматически будет быстрее, потому что вам не придется копировать все это, просто чтобы добавить столбец:

library(data.table)
dt = as.data.table(df)  # or use setDT to convert in place

dt[, newcol := lapply(vars, setdiff, 'a')][sapply(newcol, length) != 0]
#   id  vars newcol
#1:  2 a,b,c    b,c
#2:  3   b,c    b,c

Вы также можете удалить исходный столбец (с нулевой стоимостью), добавив [, vars := NULL] в конце). Или вы можете просто перезаписать начальный столбец, если вам не нужна эта информация, т.е. dt[, vars := lapply(vars, setdiff, 'a')],

Теперь, насколько алгоритмические улучшения идут, предполагая, что ваш id значения уникальны для каждого vars (а если нет, добавьте новый уникальный идентификатор), я думаю, что это намного быстрее и автоматически выполняет фильтрацию:

dt[, unlist(vars), by = id][!V1 %in% 'a', .(vars = list(V1)), by = id]
#   id vars
#1:  2  b,c
#2:  3  b,c

Для переноса других столбцов, я думаю, проще всего объединить обратно:

dt[, othercol := 5:7]

# notice the keyby
dt[, unlist(vars), by = id][!V1 %in% 'a', .(vars = list(V1)), keyby = id][dt, nomatch = 0]
#   id vars i.vars othercol
#1:  2  b,c  a,b,c        6
#2:  3  b,c    b,c        7
Источник

Вот еще один способ:

# prep
DT <- data.table(df)
DT[,vstr:=paste0(sort(unlist(vars)),collapse="_"),by=1:nrow(DT)]
setkey(DT,vstr)

get_badkeys <- function(x) 
  unlist(sapply(1:length(x),function(n) combn(sort(x),n,paste0,collapse="_")))

# choose values to exclude
baduns  <- c("a","b")

# subset
DT[!J(get_badkeys(baduns))]

Это довольно быстро, но это занимает ваше key,

Ориентиры. Вот выдуманный пример:

Кандидаты:

hannahh <- function(df,baduns){
    df %>% 
        mutate(vars = lapply(.$vars, setdiff, baduns)) %>% 
        filter(!!sapply(vars,length))
}
eddi    <- function(df,baduns){
        dt = as.data.table(df)
        dt[, 
          unlist(vars)
        , by = id][!V1 %in% baduns, 
          .(vars = list(V1))
        , keyby = id][dt, nomatch = 0]
}   
stevenb <- function(df,baduns){
    df %>% 
      rowwise() %>% 
      do(id = .$id, vars = .$vars, newcol = setdiff(.$vars, baduns)) %>%
      mutate(length = length(newcol)) %>%
      ungroup() %>%
      filter(length > 0)
}
frank   <- function(df,baduns){
    DT <- data.table(df)
    DT[,vstr:=paste0(sort(unlist(vars)),collapse="_"),by=1:nrow(DT)]
    setkey(DT,vstr)
    DT[!J(get_badkeys(baduns))]
}

Моделирование:

nvals  <- 4
nbads  <- 2
maxlen <- 4

nobs   <- 1e4

exdf   <- data.table(
  id=1:nobs,
  vars=replicate(nobs,list(sample(valset,sample(maxlen,1))))
)
setDF(exdf)
baduns <- valset[1:nbads]

Результаты:

system.time(frank_res   <- frank(exdf,baduns))
#   user  system elapsed 
#   0.24    0.00    0.28 
system.time(hannahh_res <- hannahh(exdf,baduns))
#   0.42    0.00    0.42
system.time(eddi_res    <- eddi(exdf,baduns))
#   0.05    0.00    0.04
system.time(stevenb_res <- stevenb(exdf,baduns))
#   36.27   55.36   93.98

Проверки:

identical(sort(frank_res$id),eddi_res$id) # TRUE
identical(unlist(stevenb_res$id),eddi_res$id) # TRUE
identical(unlist(hannahh_res$id),eddi_res$id) # TRUE

Обсуждение:

За eddi() а также hannahh(), результаты почти не меняются с nvals, nbads а также maxlen, Напротив, когда baduns идет за 20, frank() становится невероятно медленным (например, 20+ сек); это также масштабируется с nbads а также maxlen немного хуже, чем два других.

Расширение nobs, eddi()опередил hannahh() остается прежним, примерно в 10 раз. против frank()иногда оно уменьшается, а иногда остается прежним. В лучшем nobs = 1e5 Чехол для frank(), eddi() все еще в 3 раза быстрее.

Если мы перейдем от valset персонажей к чему-то, что frank() должен приводить к символу для его строки paste0 операция, оба eddi() а также hannahh() бить как nobs растет.

Тесты для этого неоднократно. Это, вероятно, очевидно, но если вам нужно сделать это "много" раз (... сколько трудно сказать), лучше создать ключевой столбец, чем проходить поднаборы для каждого набора baduns, В симуляции выше, eddi() примерно в 5 раз быстрее frank()так что я бы пошел на последнее, если бы я делал это подмножество более 10 раз.

maxbadlen    <- 2
set_o_baduns <- replicate(10,sample(valset,size=sample(maxbadlen,1)))

system.time({
    DT <- data.table(exdf)
    DT[,vstr:=paste0(sort(unlist(vars)),collapse="_"),by=1:nrow(DT)]
    setkey(DT,vstr)

    for (i in 1:10) DT[!J(get_badkeys(set_o_baduns[[i]]))]
})
# user  system elapsed 
# 0.29    0.00    0.29

system.time({
    dt = as.data.table(exdf)
    for (i in 1:10) dt[, 
      unlist(vars), by = id][!V1 %in% set_o_baduns[[i]],
      .(vars = list(V1)), keyby = id][dt, nomatch = 0]
})
# user  system elapsed 
# 0.39    0.00    0.39

system.time({
    for (i in 1:10) hannahh(exdf,set_o_baduns[[i]])
})
# user  system elapsed 
# 4.10    0.00    4.13

Итак, как и ожидалось, frank() занимает очень мало времени для дополнительных оценок, в то время как eddi() а также hannahh() расти линейно.

Источник

Вот еще одна идея:

df %>% 
  rowwise() %>% 
  do(id = .$id, vars = .$vars, newcol = setdiff(.$vars, "a")) %>%
  mutate(length = length(newcol)) %>%
  ungroup()

Который дает:

#  id    vars newcol length
#1  1       a             0
#2  2 a, b, c   b, c      2
#3  3    b, c   b, c      2

Затем вы можете фильтровать length > 0 хранить только непустые newcol

df %>% 
  rowwise() %>% 
  do(id = .$id, vars = .$vars, newcol = setdiff(.$vars, "a")) %>%
  mutate(length = length(newcol)) %>%
  ungroup() %>%
  filter(length > 0)

Который дает:

#  id    vars newcol length
#1  2 a, b, c   b, c      2
#2  3    b, c   b, c      2

Примечание. Как отметил @Arun в комментариях, этот подход довольно медленный. Вам лучше с data.table решения.

Источник
Другие вопросы по тегам