在lapply

Question

我正在设计一个适合模型的软件包，该模型涉及矩阵列的基础扩展。我希望扩展能够由用户定义，以便可以进行任何扩展，例如splines::bs，splines::ns，stats::poly。相同的扩展将应用于矩阵的每一列。我已尝试过eval和substitute的某些组合，但无法在嵌套函数中使用它。

我想做什么

set.seed(123)
(mat <- replicate(4, rnorm(10)))
#>              [,1]       [,2]       [,3]        [,4]
#>  [1,] -0.56047565  1.2240818 -1.0678237  0.42646422
#>  [2,] -0.23017749  0.3598138 -0.2179749 -0.29507148
#>  [3,]  1.55870831  0.4007715 -1.0260044  0.89512566
#>  [4,]  0.07050839  0.1106827 -0.7288912  0.87813349
#>  [5,]  0.12928774 -0.5558411 -0.6250393  0.82158108
#>  [6,]  1.71506499  1.7869131 -1.6866933  0.68864025
#>  [7,]  0.46091621  0.4978505  0.8377870  0.55391765
#>  [8,] -1.26506123 -1.9666172  0.1533731 -0.06191171
#>  [9,] -0.68685285  0.7013559 -1.1381369 -0.30596266
#> [10,] -0.44566197 -0.4727914  1.2538149 -0.38047100

fit <- function(x, expr = splines::bs(i, df = 5)) {

  nvars <- ncol(x)
  x <- scale(x, center = TRUE, scale = FALSE)

  design <- design_mat(x = x, expr = expr, nvars = nvars)

  # then fit some model on design

}

design_mat <- function(x, expr, nvars) {

  lapply(seq_len(nvars), function(j) expr(x[, j]))

}

fit(x = mat)
#> Error in splines::bs(i, df = 5): object 'i' not found

我尝试了什么

set.seed(123)
mat <- replicate(4, rnorm(10))

fit <- function(x, expr = splines::bs(i, df = 5)) {
  sexpr <- substitute(expr)
  sexpr[[2]] <- substitute(x[,j])

  lapply(seq_len(ncol(x)), function(j) eval(sexpr))

}

result <- fit(x = mat)
lapply(result, head)
#> [[1]]
#>                 1            2          3           4         5
#> [1,] 0.2869090697 0.6076093707 0.10273054 0.000000000 0.0000000
#> [2,] 0.0415525644 0.6427602520 0.31195968 0.003727506 0.0000000
#> [3,] 0.0000000000 0.0003743454 0.01981069 0.247406189 0.7324088
#> [4,] 0.0001816776 0.4352403899 0.51334496 0.051232973 0.0000000
#> [5,] 0.0000000000 0.3905258786 0.53866977 0.070804348 0.0000000
#> [6,] 0.0000000000 0.0000000000 0.00000000 0.000000000 1.0000000
#> 
#> [[2]]
#>                 1          2         3          4         5
#> [1,] 0.0000000000 0.02198301 0.3045954 0.49460707 0.1788145
#> [2,] 0.0011185047 0.35509930 0.6295682 0.01421403 0.0000000
#> [3,] 0.0003890728 0.32724596 0.6499248 0.02244016 0.0000000
#> [4,] 0.0246803968 0.50883712 0.4664825 0.00000000 0.0000000
#> [5,] 0.2872342378 0.53361187 0.1461208 0.00000000 0.0000000
#> [6,] 0.0000000000 0.00000000 0.0000000 0.00000000 1.0000000
#> 
#> [[3]]
#>               1         2          3           4 5
#> [1,] 0.35168337 0.5649939 0.08306911 0.000000000 0
#> [2,] 0.00000000 0.3231237 0.55125784 0.125618496 0
#> [3,] 0.30267559 0.5962519 0.10107251 0.000000000 0
#> [4,] 0.07651472 0.6370926 0.28014756 0.006245077 0
#> [5,] 0.03869768 0.5949041 0.35104880 0.015349416 0
#> [6,] 0.00000000 0.0000000 0.00000000 0.000000000 0
#> 
#> [[4]]
#>               1            2           3         4         5
#> [1,] 0.02100644 2.785920e-01 0.530958302 0.1694432 0.0000000
#> [2,] 0.55111536 5.535714e-02 0.001433639 0.0000000 0.0000000
#> [3,] 0.00000000 0.000000e+00 0.000000000 0.0000000 1.0000000
#> [4,] 0.00000000 1.946324e-05 0.004217654 0.2228812 0.7728817
#> [5,] 0.00000000 1.578049e-03 0.068681551 0.6628659 0.2668745
#> [6,] 0.00000000 3.492500e-02 0.350034463 0.6150405 0.0000000

Answer 1

是的，你关闭了。你只需要将表达式作为一个函数。

fit <- function(x, expr = function(i) splines::bs(i, df = 5)) {
  nvars <- ncol(x)
  x <- scale(x, center = TRUE, scale = FALSE)
  design <- design_mat(x = x, expr = expr, nvars = nvars)
  # then fit some model on design
}

Answer 2

这是另一种使用非标准评估来更改通话rlang的解决方案。基本思想依赖于使用fit <- function(expr = splines::bs(x, df = 6)) { sexpr <- rlang::enexpr(expr) new_expr <- call2(sexpr[[1]], call2(`[`, sexpr[[2]], call2(seq_len, call2(nrow, sexpr[[2]])), sym("i")), splice(as.list(sexpr)[-c(1:2)])) seq_col <- call2(seq_len, call2(ncol, sexpr[[2]])) design <- lapply(eval(seq_col), function(i) eval(new_expr)) # then fit some model on design } 包来更改从用户捕获的抽象语法树。这是解决方案;详细信息如下：

splines::bs(x, df = 6)

详细

用户提供的表达

  

splines::bs(x[,i], df = 6)

您想要衍生的表达

  

rlang::call2

我们将使用函数base::eval创建一个函数调用，然后使用sexpr <- rlang::enexpr(expr)进行评估。

1。从用户

捕获表达式

这很简单：sexpr。现在我们可以将函数提取为类似列表的对象x[,i]的第一个槽，其他槽对应于传递给该函数的参数。

2。创建`[`(x, seq_len(nrow(x)), i)

我们首先需要以前缀形式重写此内容：nrow(x)。我们现在看到我们有三个嵌套函数。我们可以按如下方式创建第一个电话call2(nrow, sym("x"))：sym("x")。但请回想一下，也可以从sexpr的第二个广告位中提取符号call2(nrow, sexpr[[2]])，这会提供x[,i]。继续这样，我们可以得到call2(`[`, sexpr[[2]], call2(seq_len, call2(nrow, sexpr[[2]])), sym("i")) 如下：

splines::bs(x[,i], df = 6)

3。创建rlang::splice

这很棘手，因为我们需要跟踪额外的参数。为此，我们可以使用函数foo。如果我们让`call2(sexpr[[1]], foo, splice(as.list(sexpr)[-c(1:2)]))` 成为上面步骤2中创建的表达式，我们可以写

sexpr

请注意，我们从x删除了第一个和第二个广告位，分别对应于函数和矩阵seq_len(ncol(x))。

4。创建call2(seq_len, call2(ncol, sexpr[[2]]))

我们现在非常擅长：lapply(eval(seq_col), function(i) eval(new_expr))

5。把它们放在一起并评估

这是最后一行?