将随机选择的参与者的数据与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（复制（100，MyFun（df），simplify = 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  

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