将随机选择的参与者的数据与 dplyr 相结合

Question

我有以下数据框'df'。 每个参与者（这里是 10 个参与者）看到了几个刺激物（这里是 100 个），并做出了 关于它的判断（这里是一个随机数）。对于每一个刺激，我都知道真实的 答案（这里是一个随机数；每个刺激都有一个不同的数字，但总是 所有参与者的答案相同）

participant <- rep(1:10, each=100)
stimuli <- rep(1:100, 10)
judgment <- rnorm(1000)
df1 <- data.frame(participant, stimuli, judgment)
df2 <- data.frame(stimuli=1:100, criterion=rnorm(100))
df <- merge(df1, df2, by='stimuli') %>% arrange(participant, stimuli)

这是我想要做的：

1) 随机选择 n 个参与者（这里 n 介于 1 和 10 之间）。

2) 计算他们对每个刺激的判断的平均值

3) 计算该均值与真实答案之间的相关性

我想对所有 n 执行步骤 1-3（即我想随机选择 1 名参与者并执行步骤 1-3，然后我想随机选择 2 名参与者并执行步骤 1-3 .. . 10 名随机选择的参与者并执行步骤 1-3。 结果应该是一个包含 10 行和 2 个变量的数据框：N 和相关性。我只想使用 dplyr。

我的解决方案是基于 lapply。这里是：

participants_id = unique (df$participant)      

MyFun = function(Data) {

HelpFun = function(x, Data) { 
# x is the index for the number of participants.
# It Will be used in the lapply call bellow
participants_x = sample(participants_id, x)
filter(Data, participant %in% participants_x) %>% 
  group_by(stimuli) %>% 
  summarise( mean_x = mean(judgment),
             criterion = unique(criterion) ) %>%
  summarise(cor = cor(.$mean_x, .$criterion))
  }
 N <- length(unique(Data$participant))

lapply(1:N, HelpFun, Data) %>% bind_rows()
}  

MyFun(df) 

问题是这段代码很慢。由于每次选择都是随机的，我 执行所有这些 10,000 次。而且这个慢。在我的机器（Windows 10、16 GB）上，1000 次模拟需要 2 分钟。 10,000 次模拟需要 20 分钟。 （我也尝试过使用循环，但它没有帮助，尽管由于某些原因它有点快）。它必须是一个更快的解决方案。毕竟，计算并没有那么复杂。 下面我写了100个模拟只是为了不干扰你的电脑。 system.time(replicate(100, MyFun(df), simple = FALSE) %>% bind_rows())

有没有让这一切变得更快的想法？

Answer 1

使用data.table 和 for 循环，我们可以获得快 10 倍的解决方案。 我的功能：

minem <- function(n) { # n - simulation count
  require(data.table)
  participants_id <- unique(df$participant)    
  N <- length(unique(df$participant))
  dt <- as.data.table(df)
  setkey(dt, stimuli)
  L <- list()
  for (j in 1:n) {
    corss <- rep(0, N)
    for (i in 1:N) {
      participants_x <- sample(participants_id, i)
      xx <- dt[participant %in% participants_x,
               .(mean_x = mean(judgment),
                 criterion = first(criterion)),
               by = stimuli]
      corss[i] <- cor(xx$mean_x, xx$criterion)
    }
    L[[j]] <- corss
  }
  unlist(L)
}

head(minem(10))
# [1]  0.13642499 -0.02078109 -0.14418400  0.04966805 -0.09108837 -0.15403185

你的功能：

Meir <- function(n) {
  replicate(n, MyFun(df), simplify = FALSE) %>% bind_rows()
}

基准测试：

microbenchmark::microbenchmark(
  Meir(10),
  minem(10),
  times = 10)
# Unit: milliseconds
#      expr       min        lq      mean    median        uq       max neval cld
#  Meir(10) 1897.6909 1956.3427 1986.5768 1973.5594 2043.4337 2048.5809    10   b
# minem(10)  193.5403  196.0426  201.4132  202.1085  204.9108  215.9961    10  a 

大约快 10 倍

system.time(minem(1000)) # ~19 sek

更新

如果您的数据大小和内存限制允许，那么您可以使用这种方法更快地完成：

minem2 <- function(n) {
  require(data.table)
  participants_id <- unique(df$participant)    
  N <- length(unique(df$participant))
  dt <- as.data.table(df)
  setkey(dt, participant)
  L <- lapply(1:n, function(x) 
    sapply(1:N, function(i)
      sample(participants_id, i)))
  L <- unlist(L, recursive = F)
  names(L)  <- 1:length(L)
  g <- sapply(seq_along(L), function(x) rep(names(L[x]), length(L[[x]])))
  L <- data.table(participant = unlist(L), .id = as.integer(unlist(g)),
                  key = "participant")
  L <- dt[L, allow.cartesian = TRUE]
  xx <- L[, .(mean_x = mean(judgment), criterion = first(criterion)),
          keyby = .(.id, stimuli)]
  xx <- xx[, cor(mean_x, criterion), keyby = .id][[2]]
  xx
}

microbenchmark::microbenchmark(
  Meir(100),
  minem(100),
  minem2(100),
  times = 2, unit = "relative")
# Unit: relative
#        expr       min        lq      mean    median        uq       max neval cld
#   Meir(100) 316.34965 316.34965 257.30832 257.30832 216.85190 216.85190     2   c
#  minem(100)  31.49818  31.49818  26.48945  26.48945  23.05735  23.05735     2  b 
# minem2(100)   1.00000   1.00000   1.00000   1.00000   1.00000   1.00000     2 a  

但是你需要自己测试一下。