Passing a function as an argument to FUN in lapply

Question

I'm designing a package which fits a model that involves basis expansions of columns of a matrix. I want the expansion to be user defined, so that any expansion is possible such as splines::bs, splines::ns, stats::poly. The same expansion is to be applied to every column of a matrix. I've tried some combinations of eval and substitute but cannot get it to work in nested functions.

What I'm trying to do

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

What I've tried

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

Here's another solution that uses non-standard evaluation to change the call splines::bs(x, df = 6). The basic idea relies on using the rlang package to change the abstract syntax tree captured from the user. Here's the solution; the details appear below:

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
}

Details

The expression supplied by the user

splines::bs(x, df = 6)

The expression you would like to derive

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

We will use the function rlang::call2 to create a function call that will then be evaluated using base::eval.

1. Capture the expression from the user

This is straightforward: sexpr <- rlang::enexpr(expr). Now we can extract the function as the first slot of the list-like object sexpr, and the other slots correspond to the arguments passed to this function.

2. Create x[,i]

We first need to rewrite this in prefix form: `[`(x, seq_len(nrow(x)), i). We now see that we have three nested functions. We can create the first call nrow(x) as follows: call2(nrow, sym("x")). But recall that the symbol sym("x") can also be extracted from the second slot of sexpr, which gives call2(nrow, sexpr[[2]]). Continuing this way, we can get x[,i] as follows:

call2(`[`, 
      sexpr[[2]],
      call2(seq_len,
            call2(nrow,
                  sexpr[[2]])),
      sym("i"))

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

This is tricky, because we need to keep track of the extra arguments. For this, we can use the function rlang::splice. If we let foo be the expression created in step 2 above, we can write

`call2(sexpr[[1]], foo, splice(as.list(sexpr)[-c(1:2)]))`

Note that we dropped the first and second slots from sexpr, which correspond to the function and the matrix x, respectively.

4. Create seq_len(ncol(x))

We're pretty good at this now: call2(seq_len, call2(ncol, sexpr[[2]]))

5. Put it all together and evaluate

This is the last line lapply(eval(seq_col), function(i) eval(new_expr))

Answer 2

Ooh, you're close. You just need the expression to be a function.

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
}