如何提高一个函数的效率

Question

我编写此函数是为了将具有 categorical 变量且仅具有观察到的类别组合的数据集转换为包含所有可能的组合的数据集，这些组合可以通过考虑的变量和类别找到。此外，我希望有一列“y”包含行的频率，所以我在原始数据集中观察了多少次这种模式。

datafreq <- function(dati) {
  dati = na.omit(dati)
  dati[] = lapply(dati, factor)
  dati <-  dati %>%
    group_by_all(.drop = FALSE) %>%
    summarise(y = n()) %>%
    ungroup()
  return(as.data.frame(dati))
}

所以例如你有数据集votes可以在UCI机器学习库中找到https://archive.ics.uci.edu/ml/datasets/congressional+voting+records.

它有 435 行，每一行都有 16 个分类变量的值的组合。

我想获得一个包含 3^16 行的数据集，一个用于变量类别的每个组合（观察到和未观察到）（每个变量有 3 个可能的类别）。应该创建一个变量 y 来计算每个组合在数据中被观察到的次数（如果从未被观察到则为 0）。

我编写的函数运行良好，并且在非常小的数据集 下完成了它应该做的事情。但是，当与投票等大型数据集一起使用时，R 会崩溃。 所以我想问有没有更高效的功能可以使用，如何提高效率？

谢谢！

Answer 1

我不完全清楚为什么你需要利用因素，但这样的事情会奏效吗？

library(dplyr)
library(tidyr)
datafreq <- function(dati){
  dati <- na.omit(dati)
  dati %>%
    count(across(everything()), name = "y") %>%
    complete(!!!syms(setdiff(names(dati), "y")),
             fill = list(y = 0))
    
}

编辑： 更新答案以反映 OP 的更新问题。

我不确定这是否会达到您正在寻找的效率，但您可以使用的一些功能是数据中的所有组合。

一个可能的解决方案可能是计算现有组合，展开所有组合并加入计数。

DPLYR/TIDYR

expand.grid()

数据表

或者，这里有一个 data.table 解决方案

data.table::CJ()

与

tidyr::expand()

：

Answer 2

library(data.table)
datafreq2 <- function(dati){
  # Coerce to DT
  dati <- as.data.table(dati)
  # Remove NAs
  dati <- na.omit(dati) 
  # COUNT
  counts <- dati[, list(y = .N), by = names(dati)]
  # EXPAND
  out <- do.call(get("CJ", asNamespace("data.table")),
                 args = c(dati, sorted = TRUE, unique = TRUE))
  # FULL-JOIN
  out <- merge(counts, out,
               all = TRUE, 
               by = names(out), sort = FALSE)
  # REPLACE NA counts with 0
  setnafill(out, type = "const", fill = 0, cols = "y")
  out
}
df <- as.data.table(df)
out <- datafreq2(df[, .SD, .SDcols = setdiff(names(df), "republican")])

中的值是

data.table

中值的索引，所以

library(data.table)

dt <- fread("C:/temp/house-votes-84.data", header = FALSE)
u <- lapply(dt, unique)
a <- rev(cumprod(c(1, rev(lengths(u)[-1]))))
dt2 <- do.call(CJ, lapply(lengths(u), seq.int))
dt2[,counts := tabulate(colSums(t(mapply(function(i) match(dt[[i]], u[[i]]), seq_along(dt)) - 1)*a) + 1, .N)]
nrow(dt) == sum(dt2$counts)
#> [1] TRUE

对应于

dt

.