r - 在R中建立值的特定组合；更改一个变量，使所有其他变量保持不变

我如何使用apply()系列或其他函数从a，b和Change开始构建下面的输出？我正在寻找一种通用方法，该方法将扩展到不仅仅是a和b的更多变量，如我的示例所示。

当对一个变量进行更改时，输出将使其他变量保持恒定。最终，我正在尝试为简单的敏感性分析建立这一基础。我所做的事情似乎过于复杂。

library(tidyverse)

a <- 10
b <- 100
Change <- seq(-20,20,10)

df3 <- NULL

for (i in a) {
  for (j in b) {
    for (k in Change) {
      df <- data.frame(a_ = i, b_ = j * (1 + k / 100))
      df2 <- data.frame(a_ = i * (1 + k / 100), b_ = j)
      df3 <- bind_rows(df, df2, df3)
    }
  }
}
df3 %>% distinct() %>% arrange(a_)

输出

  a_  b_
1  8 100
2  9 100
3 10 120
4 10 110
5 10 100
6 10  90
7 10  80
8 11 100
9 12 100

最佳答案

通过大量使用base R和lapply，可以将该任务扩展到do.call中的任意数量的变量。我们还注意到expand.grid和append的关键而简单的用法。

specialCombs <- function(myVars, ChangeVec) {
    myLen <- length(myVars) * length(ChangeVec)

    mat <- do.call(rbind, lapply(seq_along(myVars), function(x) {
        staticVar <- lapply(myVars[-x], function(z) {
            lapply(z, rep, length(ChangeVec))
        })

        ## Cartestian Product
        CP <- expand.grid(lapply(lengths(staticVar), seq_len))

        ## Use the cartestian product above (CP) to build all
        ## possible combinations of static columns
        expandStatic <- lapply(1:nrow(CP), function(i) {
            lapply(seq_along(CP[i, ]), function(j) {
                staticVar[[j]][[CP[i, j]]]
            })
        })

        do.call(rbind, lapply(myVars[[x]], function(y) {
            dynVar <- list(y * (1 + ChangeVec / 100))

            ## Place the dynamic vector in the appropriate position
            ## before building a matrix chunk via append and cbind
            do.call(rbind, lapply(expandStatic, function(res) {
                do.call(cbind, append(res, dynVar, after = x - 1))
            }))
        }))
    }))

    mat <- mat[do.call(order, as.data.frame(mat)), ]
    unique(mat)
}

通过OP给出的示例:

specialCombs(list(10, 100), Change)
     [,1] [,2]
[1,]    8  100
[2,]    9  100
[3,]   10   80
[4,]   10   90
[5,]   10  100
[6,]   10  110
[7,]   10  120
[8,]   11  100
[9,]   12  100

举一个更奇特的例子:

specialCombs(list(8:10, 95:100, 150:153, 200:205), Change)
        [,1] [,2] [,3] [,4]
   [1,]  6.4   95  150  200
   [2,]  6.4   95  150  201
   [3,]  6.4   95  150  202
   [4,]  6.4   95  150  203
   [5,]  6.4   95  150  204
   [6,]  6.4   95  150  205
      .    .    .    .    .
      .    .    .    .    .
      .    .    .    .    .
[6907,]   12  100  153  200
[6908,]   12  100  153  201
[6909,]   12  100  153  202
[6910,]   12  100  153  203
[6911,]   12  100  153  204
[6912,]   12  100  153  205

效率也更高:

OP_code <- function(a, b) {
    df3 <- NULL

    for (i in a) {
        for (j in b) {
            for (k in Change) {
                df <- data.frame(a_ = i, b_ = j * (1 + k / 100))
                df2 <- data.frame(a_ = i * (1 + k / 100), b_ = j)
                df3 <- bind_rows(df, df2, df3)
            }
        }
    }

    df3 %>% distinct() %>% arrange(a_)
}


library(microbenchmark)
microbenchmark(op_code = OP_code(5:15, 85:115),
               new_code = specialCombs(list(5:15, 85:115), Change),
               times = 10, unit = "relative")
Unit: relative
    expr     min       lq     mean   median       uq      max neval
 op_code 73.8084 75.13821 68.30254 69.97878 63.20355 57.79337    10
new_code  1.0000  1.00000  1.00000  1.00000  1.00000  1.00000    10

这是一个非常大的示例:

system.time(test_1 <- OP_code(1:50, 80:180))
 user  system elapsed
16.91    0.27   17.23

system.time(test_2 <- specialCombs(list(1:50, 80:180), Change))
user  system elapsed
0.09    0.01    0.11

dim(test_1)
[1] 37357     2

## The order is different, so we must sort
identical(unname(as.matrix(
     test_1[do.call(order, test_1), ])), test_2)
[1] TRUE