Передача функции в качестве аргумента FUN в lapply
Я разрабатываю пакет, который подходит для модели, которая включает базовые расширения столбцов матрицы. Я хочу, чтобы расширение было определено пользователем, так что возможно любое расширение, такое как 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
2 ответа
О, ты близко. Вам просто нужно выражение, чтобы быть функцией.
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
}
Вот еще одно решение, которое использует нестандартную оценку для изменения вызова splines::bs(x, df = 6), Основная идея основана на использовании 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,
1. Захватить выражение от пользователя
Это просто: sexpr <- rlang::enexpr(expr), Теперь мы можем извлечь функцию в качестве первого слота объекта, подобного списку. sexpr, а другие слоты соответствуют аргументам, переданным этой функции.
2. Создать x[,i]
Сначала нам нужно переписать это в виде префикса: `[`(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"))
3. Создать splines::bs(x[,i], df = 6)
Это сложно, потому что нам нужно отслеживать дополнительные аргументы. Для этого мы можем использовать функцию rlang::splice, Если мы позволим foo быть выражением, созданным на шаге 2 выше, мы можем написать
`call2(sexpr[[1]], foo, splice(as.list(sexpr)[-c(1:2)]))`
Обратите внимание, что мы опустили первый и второй слоты из sexpr, которые соответствуют функции и матрице xсоответственно.
4. Создать seq_len(ncol(x))
Сейчас мы довольно хороши: call2(seq_len, call2(ncol, sexpr[[2]]))
5. Соберите все вместе и оцените
Это последняя строка lapply(eval(seq_col), function(i) eval(new_expr))