R 将嵌套循环转换为lappy

我使用两个循环。在第二个循环中，我将值递增1，然后在此基础上应用过滤器，并将其转换为data.matrix，以便在后面的步骤中进行矩阵乘法。是否有任何方法可以使用lappy、expand.grid或任何其他方法提高效率

library(dplyr)
xx <- structure(list(Ars_0 = c(1308.56, 5728.84, 2177.82), Ars_1 = c(0, 0, 0), 
                    Ars_2 = c(0, 0, 0), age = c(13, 31, 43), region = c('A','A','B')), 
               row.names = c(NA, -3L), 
               class = "data.frame")


mx_long2 = read.table(header = T, text = '
                      Arrears   Ars_0   Ars_1   Ars_2   Seasoning   Region
                      Ars_0 0.985   0.0148  0.0002  mths:36-47  A
                      Ars_1 0.3816  0.286   0.3317  mths:36-47  A
                      Ars_2 0.2959  0.0057  0.2524  mths:36-47  A
                      Ars_0 0.9822  0.0176  0.0002  mths:24-35  A
                      Ars_1 0.389   0.2753  0.3347  mths:24-35  A
                      Ars_2 0.3026  0.0334  0.2399  mths:24-35  A
                      Ars_0 0.9753  0.0243  0.0004  mths:12-23  A
                      Ars_1 0.4002  0.2592  0.3394  mths:12-23  A
                      Ars_2 0.3032  0.0208  0.2387  mths:12-23  A
                      Ars_0 0.8865  0.01332 0.00018 mths:36-47  B
                      Ars_1 0.34344 0.2574  0.29853 mths:36-47  B
                      Ars_2 0.26631 0.00513 0.22716 mths:36-47  B
                      Ars_0 0.88398 0.01584 0.00018 mths:24-35  B
                      Ars_1 0.3501  0.24777 0.30123 mths:24-35  B
                      Ars_2 0.27234 0.03006 0.21591 mths:24-35  B
                      Ars_0 0.87777 0.02187 0.00036 mths:12-23  B
                      Ars_1 0.36018 0.23328 0.30546 mths:12-23  B
                      Ars_2 0.27288 0.01872 0.21483 mths:12-23  B
                      ')


mx_long2 = mx_long2 %>% mutate(minage = as.numeric(substr(as.character(Seasoning), 6,7)),
                               maxage = as.numeric(substr(as.character(Seasoning), 9,10)))


x <- xx %>% select(starts_with('Ars')) %>% data.matrix()

l <- list()
p <- 1

for (i in 1:nrow(x)) {
  for (j in 1:3) {
    Bx = filter(mx_long2, (j + xx[i, 'age']) >= minage, (j + xx[i, 'age']) <= maxage,
                Region == xx[i, 'region']) %>%
      select(starts_with('Ars_')) %>% data.matrix()

    # Matrix Multiplication
    x <-  x %*% Bx
    l[[p]] <- x
    p = p + 1
  }
  }

l

---

下面是使用data.table的另一个选项：

---

下面是使用data.table的另一个选项：

---

这里有一个答案，把所有的东西连接起来，然后分开：

library(tidyr)
library(dplyr)

xx%>%
  mutate(id_xx = seq_len(n()))%>%
  crossing(j = 1:3)%>%
  mutate(age = age + j)%>%
  inner_join(mx_long2, ., by = c('Region' = 'region'))%>%
  filter(age >= minage, age <= maxage)%>%
  arrange(j, id_xx)%>%
  select(starts_with('Ars_'))%>%
  select(ends_with('x'))%>%
  split(rep(1:9, each = 3))%>%
  lapply(function(Bx) {
    x <<- x %*% as.matrix(Bx)
    return(x)
  })

以及类似的方法：

---

这里有一个答案，把所有的东西连接起来，然后分开：

library(tidyr)
library(dplyr)

xx%>%
  mutate(id_xx = seq_len(n()))%>%
  crossing(j = 1:3)%>%
  mutate(age = age + j)%>%
  inner_join(mx_long2, ., by = c('Region' = 'region'))%>%
  filter(age >= minage, age <= maxage)%>%
  arrange(j, id_xx)%>%
  select(starts_with('Ars_'))%>%
  select(ends_with('x'))%>%
  split(rep(1:9, each = 3))%>%
  lapply(function(Bx) {
    x <<- x %*% as.matrix(Bx)
    return(x)
  })

以及类似的方法：

---

下面是我使用purrr进行嵌套循环的方法

---

不过，l和我的_列表之间的结果有一些小差异。我不知道为什么会这样。我是否遗漏了代码中的一些随机部分？

下面是我使用purrr进行嵌套循环的方法

---

不过，l和我的_列表之间的结果有一些小差异。我不知道为什么会这样。我是否遗漏了代码中的一些随机部分？

您对PURRR解决方案感兴趣吗？是的。Definitely@john你能分享结果的片段以供检查吗？抱歉，因为我没有tidyverse来运行您的一些代码您对Purrr解决方案感兴趣吗？是的。Definitely@john你能分享结果的片段以供检查吗？对不起，我没有tidyverse来运行你的一些代码库。我需要列表中每个迭代的输出。当我离开系统时，我将在一段时间内添加输出。非常感谢你的努力谢谢。我需要列表中每个迭代的输出。当我离开系统时，我将在一段时间内添加输出。非常感谢你的努力

library(tidyr)
library(dplyr)

xx%>%
  mutate(id_xx = seq_len(n()))%>%
  crossing(j = 1:3)%>%
  mutate(age = age + j)%>%
  inner_join(mx_long2, ., by = c('Region' = 'region'))%>%
  filter(age >= minage, age <= maxage)%>%
  arrange(j, id_xx)%>%
  select(starts_with('Ars_'))%>%
  select(ends_with('x'))%>%
  split(rep(1:9, each = 3))%>%
  lapply(function(Bx) {
    x <<- x %*% as.matrix(Bx)
    return(x)
  })

library(data.table)

x <- xx %>% select(starts_with('Ars')) %>% data.matrix()
mx_dt <- as.data.table(mx_long2)

# prepare xx for a join by expanding it by 3
j <- 3
xx_dt <- as.data.table(xx)
xx_dt <- xx_dt[rep(seq_len(nrow(xx_dt)), each = j)
               ][, `:=`(age= age + rep(seq_len(j), nrow(xx_dt)),
                        ID = .I)]

# non-equi join
BX <- mx_dt[xx_dt[, .(region, age, ID)], 
      on = .(Region = region,
             minage <= age,
             maxage >= age),
      allow.cartesian = T,
      nomatch = 0L,
      .(Ars_0, Ars_1, Ars_2, ID)]

# loop through split. 
## NOTE x <<- ... the "<<-" is a global assignment
lapply(split(BX, by = 'ID', keep.by = F),
       function(bx) {
         x <<- x %*% as.matrix(bx)
         return(x)
       }
)

l
x <- xx %>% select(starts_with('Ars')) %>% data.matrix()

my_list <- purrr::pmap(
  # use expand.grid() to create your iterators
  .l = expand.grid(1:nrow(x),
                   1:3),
  .f = ~{
    Bx = filter(mx_long2, (.y + xx[.x, 'age']) >= minage, (.y + xx[.x, 'age']) <= maxage,
                Region == xx[.x, 'region']) %>%
      select(starts_with('Ars_')) %>% data.matrix()

    # Matrix Multiplication
    # global assignment operator <<-
    x <<- x %*% Bx
    return(x)
  }
)
all.equal(l, my_list)