R 当项目数量过大时检查项目各种组合的最佳算法

我有一个数据框，其中有20列/项，593行（行数并不重要），如下所示：

在psych package

psych:：alpha

的帮助下，使用该方法，测试的可靠性为0.94。如果我删除其中一个项目，输出还会给我cronbach的alpha的新值。但是，我想知道我可以删除多少项以保留至少0.8的alpha值。我使用蛮力方法创建数据帧中存在的所有项的组合，并检查它们的alpha值是否在范围内（0.7,0.9）。是否有更好的方法来执行此操作，因为这需要花费很长时间才能运行，因为项目的数量太大，无法检查所有项目的组合。下面是我当前的一段代码：

numberOfItems <- 20
for(i in 2:(2^numberOfItems)-1){
  # ignoring the first case i.e. i=1, as it doesn't represent any model
  # convert the value of i to binary, e.g. i=5 will give combination = 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1
  # using the binaryLogic package
  combination <- as.binary(i, n=numberOfItems) 
  model <- c()
  for(j in 1:length(combination)){
    # choose which columns to consider depending on the combination
    if(combination[j])
      model <- c(model, j)
  }
  itemsToUse <- itemResponses[, c(model)]
  #cat(model)
  if(length(model) > 13){
    alphaVal <- psych::alpha(itemsToUse)$total$raw_alpha
    if(alphaVal > 0.7 && alphaVal < 0.9){
      cat(alphaVal)
      print(model)
    }
  }
}

---

numberOfItems我按如下方式更改了代码，现在我正在删除固定数量的项目，并手动将
numberOfItems的值从1更改为20。虽然它是一个lil更好，但它仍然需要很长时间才能运行：(

我希望有更好的办法

numberOfItemsToDrop <- 13
combinations <- combinat::combn(20, numberOfItemsToDrop)
timesToIterate <- length(combinations)/numberOfItemsToDrop
for(i in 1:timesToIterate){
  model <- combinations[,i]
  itemsToUse <- itemResponses[, -c(model)]
  alphaVal <- psych::alpha(itemsToUse)$total$raw_alpha
  if(alphaVal < 0.82){
    cat("Cronbach's alpha =",alphaVal, ", number of items dropped = ", length(model), " :: ")
    print(model)
  }
}

numberOfItemsToDrop这个想法是用经典测试理论（CTT）中对每个项目的所谓区分来代替
alpha
的计算。区分是项目分数与“真实分数”（我们假设为行和）的相关性

让数据自由流动

dat <-  structure(list(CESD1 = c(1, 2, 2, 0, 1, 0, 0, 0, 0, 1), CESD2 = c(2, 3, 1, 0, 0, 1, 1, 1, 0, 1), 
                       CESD3 = c(0, 3, 0, 1, 1, 0, 0, 0, 0, 0), CESD4 = c(1, 2, 0, 1, 0, 1, 1, 1, 0, 0), 
                       CESD5 = c(0, 1, 0, 2, 1, 2, 2, 0, 0, 0), CESD6 = c(0, 3, 0, 1, 0, 0, 2, 0, 0, 0), 
                       CESD7 = c(1, 2, 1, 1, 2, 0, 1, 0, 1, 0), CESD8 = c(1, 3, 1, 1, 0, 1, 0, 0, 1, 0), 
                       CESD9 = c(0, 1, 0, 2, 0, 0, 1, 1, 0, 1), CESD10 = c(0, 1, 0, 2, 0, 0, 1, 1, 0, 1), 
                       CESD11 = c(0, 2, 1, 1, 1, 1, 2, 3, 0, 0), CESD12 = c(0, 3, 1, 1, 1, 0, 2, 0, 0, 0), 
                       CESD13 = c(0, 3, 0, 2, 1, 2, 1, 0, 1, 0), CESD14 = c(0, 3, 1, 2, 1, 1, 1, 0, 1, 1), 
                       CESD15 = c(0, 2, 0, 1, 0, 1, 0, 1, 1, 0), CESD16 = c(0, 2, 2, 0, 0, 1, 1, 0, 0, 0), 
                       CESD17 = c(0, 0, 0, 0, 0, 1, 1, 0, 0, 0), CESD18 = c(0, 2, 0, 0, 0, 0, 0, 0, 0, 1), 
                       CESD19 = c(0, 3, 0, 0, 0, 0, 0, 1, 1, 0), CESD20 = c(0, 3, 0, 1, 0, 0, 0, 0, 0, 0)), 
                  .Names = c("CESD1", "CESD2", "CESD3", "CESD4", "CESD5", "CESD6", "CESD7", "CESD8", "CESD9", 
                             "CESD10", "CESD11", "CESD12", "CESD13", "CESD14", "CESD15", "CESD16", "CESD17", 
                             "CESD18", "CESD19", "CESD20"), row.names = c(NA, -10L), 
                  class = c("tbl_df", "tbl", "data.frame"))


使用此信息选择删除项目的顺序，使其低于基准（例如.9，因为玩具数据不允许较低的分数）：

1）删除尽可能多的项目以保持高于基准；也就是说，从辨别力最低的项目开始

stat <- stat[order(stat$disc), ]
this <- sapply(1:(nrow(stat)-2), function(ii){
  ind <- match(rownames(stat)[1:ii], colnames(dat))
  alpha <- psych::alpha(dat[, -ind, drop = FALSE])$total$raw_alpha
})

delete_these <- rownames(stat)[which(this > .9)]
psych::alpha(dat[, -match(delete_these, colnames(dat)), drop = FALSE])$total$raw_alpha
length(delete_these)

stat <- stat[order(stat$disc, decreasing = TRUE), ]
this <- sapply(1:(nrow(stat)-2), function(ii){
  ind <- match(rownames(stat)[1:ii], colnames(dat))
  alpha <- psych::alpha(dat[, -ind, drop = FALSE])$total$raw_alpha
})

delete_these <- rownames(stat)[which(this > .9)]
psych::alpha(dat[, -match(delete_these, colnames(dat)), drop = FALSE])$total$raw_alpha
length(delete_these)

stat我认为，您可以计算每个项目（或一些其他相关指标，如INFIT）的判别指数（与行sumscore的相关性）。然后依次删除索引最低的项目（如果你想删除尽可能多的项目）并计算新的alpha，直到alpha低于。8.我不确定你想说什么。你能详细说明一下吗？我的建议来自心理测量学的观点，而不是编程的观点。为了能够有效地阐述，您是否介意提供一个可复制的示例（包括项目响应数据）和预期结果。我可以提供数据，但我不确定如何将其发送到此处。数据由20列组成，每列的值都在[0,4]范围内（不过这无关紧要）。预期结果是要保留多少项才能获得0.8（或任何目标数字）的可靠性。您可以对（合理的）数据子集应用
dput
，并将结果发布到原始帖子的编辑中。让我看一下，我需要一些时间来消化您所做的工作。谢谢你的回答。
stat <- stat[order(stat$disc), ]
this <- sapply(1:(nrow(stat)-2), function(ii){
  ind <- match(rownames(stat)[1:ii], colnames(dat))
  alpha <- psych::alpha(dat[, -ind, drop = FALSE])$total$raw_alpha
})

delete_these <- rownames(stat)[which(this > .9)]
psych::alpha(dat[, -match(delete_these, colnames(dat)), drop = FALSE])$total$raw_alpha
length(delete_these)

stat <- stat[order(stat$disc, decreasing = TRUE), ]
this <- sapply(1:(nrow(stat)-2), function(ii){
  ind <- match(rownames(stat)[1:ii], colnames(dat))
  alpha <- psych::alpha(dat[, -ind, drop = FALSE])$total$raw_alpha
})

delete_these <- rownames(stat)[which(this > .9)]
psych::alpha(dat[, -match(delete_these, colnames(dat)), drop = FALSE])$total$raw_alpha
length(delete_these)