在 R 中使用逻辑检查加速循环

Question

我正在 R 中进行一些模拟。但是，我的代码运行速度非常慢，因此不适合高 N 和大量 sims 。我已将瓶颈确定为以下功能（见下文）。它需要一个 s tibble 列表作为输入。基本上，在组 g 内（每个 g_id 两行）我想将我的参数值（概率）分配给组内的第一行（g_first == 1），假设变量 A 和 B 的值匹配特定模式g 内（即手工编码两个分类变量之间的交互）。 A 和 B 的值也存储为 1/0 变量（例如，如果 B 为 x，则 B_x 取值为 1）。

我尝试使用 data.tables 列表而不是 tibbles 作为输入，但实际上它进一步减慢了它的速度（也许 bc 下面的子集对于 data.tables 来说很慢。此外，我不知道如何为 setkey() data.tables 列表）。

根据请求，我在此链接下上传了一个示例 df（包含 100 个模拟小标题的列表）：https://ufile.io/dsax7us8。通过 lapply(df, assign_p) 调用该函数。在下面的代码中，您还可以快速浏览 df 列表的元素之一。

#a quick glance on the data structure
dput(head(df[[1]]))

structure(list(p_id = c(1L, 1L, 1L, 1L, 2L, 2L), g_id = c(1L, 
1L, 2L, 2L, 3L, 3L), pr_id = 1:6, g_first = c(1, 0, 1, 0, 1, 
0), A = c(1, 0, 1, 0, 0, 1), B = c("x", "z", "x", "x", "z", "z"
), C = c(1, 1, 1, 1, 1, 0), A_0 = c(0, 1, 0, 1, 1, 0), A_1 = c(1, 
0, 1, 0, 0, 1), B_x = c(1, 0, 1, 1, 0, 0), B_z = c(0, 1, 0, 0, 
1, 1), C_0 = c(0, 0, 0, 0, 0, 1), C_1 = c(1, 1, 1, 1, 1, 0)), row.names = c(NA, 
-6L), class = c("tbl_df", "tbl", "data.frame"))

dput(head(df[[2]]))

structure(list(p_id = c(1L, 1L, 1L, 1L, 2L, 2L), g_id = c(1L, 
1L, 2L, 2L, 3L, 3L), pr_id = 1:6, g_first = c(1, 0, 1, 0, 1, 
0), A = c(0, 0, 1, 0, 1, 0), B = c("x", "z", "z", "x", "x", "z"
), C = c(1, 1, 1, 0, 1, 0), A_0 = c(1, 1, 0, 1, 0, 1), A_1 = c(0, 
0, 1, 0, 1, 0), B_x = c(1, 0, 0, 1, 1, 0), B_z = c(0, 1, 1, 0, 
0, 1), C_0 = c(0, 0, 0, 1, 0, 1), C_1 = c(1, 1, 1, 0, 1, 0)), row.names = c(NA, 
-6L), class = c("tbl_df", "tbl", "data.frame"))

#params
A_10_B_xx <- 0.04 
A_10_B_xz <- 0.04
A_10_B_zz <- 0.003
A_10_B_zx <- 0.003

A_01_B_xx <- -0.04
A_01_B_xz <- -0.04
A_01_B_zz <- -0.003
A_01_B_zx <- -0.003


assign_p <- function(df) {


 df$p <- NA_real_
 
 g <- max(df$g_id)
 
 
 for (i in 1:g) {

#generate logical checks
   A_11 = df[df$g_id == i & df$g_first == 1, "A_1"]
   A_10 = df[df$g_id == i & df$g_first == 0, "A_1"]
   A_01 = df[df$g_id == i & df$g_first == 1, "A_0"]
   A_00 = df[df$g_id == i & df$g_first == 0, "A_0"]
   B_x1 = df[df$g_id == i & df$g_first == 1, "B_x"]
   B_x0 = df[df$g_id == i & df$g_first == 0, "B_x"]
   B_z1 = df[df$g_id == i & df$g_first == 1, "B_z"]
   B_z0 = df[df$g_id == i & df$g_first == 0, "B_z"]
  
#multiply logical checks
   A_10_B_xx_out  <- A_10_B_xx * A_11 * A_00 * B_x1 * B_x0
   
   A_10_B_xz_out  <- A_10_B_xz * A_11 * A_00 * B_x1 * B_z0
   
   A_10_B_zz_out  <- A_10_B_zz * A_11 * A_00 * B_z1 * B_z0
   
   A_10_B_zx_out  <- A_10_B_zx * A_11 * A_00 * B_z1 * B_x0
   
   A_01_B_xx_out  <- A_01_B_xx * A_01 * A_10 * B_x1 * B_x0
   
   A_01_B_xz_out  <- A_01_B_xz * A_01 * A_10 * B_x1 * B_z0
   
   A_01_B_zz_out  <- A_01_B_zz * A_01 * A_10 * B_z1 * B_z0
   
   A_01_B_zx_out  <- A_01_B_zx * A_01 * A_10 * B_z1 * B_x0
   
   
#add matches to 0.5 and assign to column p    
   df[df$g_id == i &
        df$g_first == 1, "p"] <- 0.50 +
     A_10_B_xx_out +
     A_10_B_xz_out +
     A_10_B_zz_out +
     A_10_B_zx_out +
     A_01_B_xx_out +
     A_01_B_xz_out +
     A_01_B_zz_out +
     A_01_B_zx_out
 }
 

 df 
}

Answer 1

这是一个基于您提供的单个 data.frame 的示例。如 cmets 中所述，我创建了一个查找表并尝试根据您提供的逻辑（不确定是否正确）创建一个匹配列 (param_group) 以连接两个表。

请检查以下内容：

library(data.table)

DT <- structure(list(p_id = c(1L, 1L, 1L, 1L, 2L, 2L),
                          g_id = c(1L, 1L, 2L, 2L, 3L, 3L), 
                          pr_id = 1:6,
                          g_first = c(1, 0, 1, 0, 1, 0),
                          A = c(1, 0, 1, 0, 0, 1),
                          B = c("x", "z", "x", "x", "z", "z"),
                          C = c(1, 1, 1, 1, 1, 0), A_0 = c(0, 1, 0, 1, 1, 0),
                          A_1 = c(1, 0, 1, 0, 0, 1),
                          B_x = c(1, 0, 1, 1, 0, 0),
                          B_z = c(0, 1, 0, 0, 1, 1), 
                          C_0 = c(0, 0, 0, 0, 0, 1), 
                          C_1 = c(1, 1, 1, 1, 1, 0)), 
                     row.names = c(NA, -6L), 
                     class = c("tbl_df", "tbl", "data.frame"))

setDT(DT)

parameterDT <- data.table(
  param_group = c("A_10_B_xx", "A_10_B_xz", "A_10_B_zz", "A_10_B_zx", "A_01_B_xx", "A_01_B_xz", "A_01_B_zz", "A_01_B_zx"),
  parameter = c(0.04, 0.04, 0.003, 0.003, -0.04, -0.04, -0.003, -0.003)
)

DT[, param_group := paste0("A_", paste0(.SD$A, collapse =  ""), "_B_", paste0(.SD$B, collapse =  "")), by = g_id, .SDcols = c("A", "B")]
DT <- parameterDT[DT, on = "param_group"]

DT[g_first == 1, p := 0.5 + parameter]
DT

---

   param_group parameter p_id g_id pr_id g_first A B C A_0 A_1 B_x B_z C_0 C_1     p
1:   A_10_B_xz     0.040    1    1     1       1 1 x 1   0   1   1   0   0   1 0.540
2:   A_10_B_xz     0.040    1    1     2       0 0 z 1   1   0   0   1   0   1    NA
3:   A_10_B_xx     0.040    1    2     3       1 1 x 1   0   1   1   0   0   1 0.540
4:   A_10_B_xx     0.040    1    2     4       0 0 x 1   1   0   1   0   0   1    NA
5:   A_01_B_zz    -0.003    2    3     5       1 0 z 1   1   0   0   1   0   1 0.497
6:   A_01_B_zz    -0.003    2    3     6       0 1 z 0   0   1   0   1   1   0    NA

如前所述，关于您的表格列表，我建议使用 rbindlist 创建单个 data.table。

编辑：以下是我使用 data.frames 列表作为输入的方法：

library(data.table)

df <- list(structure(
  list(
    p_id = c(1L, 1L, 1L, 1L, 2L, 2L),
    g_id = c(1L, 1L, 2L, 2L, 3L, 3L),
    pr_id = 1:6,
    g_first = c(1, 0, 1, 0, 1, 0),
    A = c(1, 0, 1, 0, 0, 1),
    B = c("x", "z", "x", "x", "z", "z"),
    C = c(1, 1, 1, 1, 1, 0),
    A_0 = c(0, 1, 0, 1, 1, 0),
    A_1 = c(1, 0, 1, 0, 0, 1),
    B_x = c(1, 0, 1, 1, 0, 0),
    B_z = c(0, 1, 0, 0, 1, 1),
    C_0 = c(0, 0, 0, 0, 0, 1),
    C_1 = c(1, 1, 1, 1, 1, 0)
  ),
  row.names = c(NA,-6L),
  class = c("tbl_df", "tbl", "data.frame")
),
structure(
  list(
    p_id = c(1L, 1L, 1L, 1L, 2L, 2L),
    g_id = c(1L, 1L, 2L, 2L, 3L, 3L),
    pr_id = 1:6,
    g_first = c(1, 0, 1, 0, 1, 0),
    A = c(0, 0, 1, 0, 1, 0),
    B = c("x", "z", "z", "x", "x", "z"),
    C = c(1, 1, 1, 0, 1, 0),
    A_0 = c(1, 1, 0, 1, 0, 1),
    A_1 = c(0, 0, 1, 0, 1, 0),
    B_x = c(1, 0, 0, 1, 1, 0),
    B_z = c(0, 1, 1, 0, 0, 1),
    C_0 = c(0, 0, 0, 1, 0, 1),
    C_1 = c(1, 1, 1, 0, 1, 0)
  ),
  row.names = c(NA,-6L),
  class = c("tbl_df", "tbl", "data.frame")
))

parameterDT <- data.table(
  param_group = c("A_10_B_xx", "A_10_B_xz", "A_10_B_zz", "A_10_B_zx", "A_01_B_xx", "A_01_B_xz", "A_01_B_zz", "A_01_B_zx"),
  parameter = c(0.04, 0.04, 0.003, 0.003, -0.04, -0.04, -0.003, -0.003)
)

DT <- rbindlist(df, idcol = TRUE)

DT[, param_group := paste0("A_", paste0(.SD$A, collapse =  ""), "_B_", paste0(.SD$B, collapse =  "")), by = .(.id, g_id), .SDcols = c("A", "B")]
DT <- parameterDT[DT, on = "param_group"]

DT[g_first == 1, p := 0.5 + parameter]
print(DT)

# back to a list of data.tables
# split(DT, by = ".id")