R Hessian Matrix

Question

I need to create the Hessian matrix of a function given as:

func <- expression(sin(x+y)+cos(x-y))
vars <- c("x", "y")

I need the second order derivatives as expressions too, and I need to evaluate them lot of times, so I made a list of first order derivatives, and a list of list of second order derivatives.

funcD <- lapply(vars, function(v) D(func, v))
funcDD <- list(); for (i in 1:length(vars)) funcDD[[i]] <- lapply(vars, function(v) D(funcD[[i]], v))

So far, it works.

> funcDD
[[1]]
[[1]][[1]]
-(sin(x + y) + cos(x - y))

[[1]][[2]]
-(sin(x + y) - cos(x - y))


[[2]]
[[2]][[1]]
cos(x - y) - sin(x + y)

[[2]][[2]]
-(cos(x - y) + sin(x + y))

Now the questions: How can I create a matrix containing values of the evaluated expressions? Tried outer, didn't work.

> h <- outer(c(1:length(vars)), c(1:length(vars)), function(r, c) eval(funcDD[[r]][[c]], envir = list(x = 1, y = 2)))
Error in funcDD[[r]] : subscript out of bounds

Other question: Is there a more elegant way to store the second order derivative expressions? For instance is it possible to store expressions in a matrix instead of lists of lists?

Third question: Is it possible to get a vector of variables of an expression? Above I used vars <- c("x", "y") which I entered as input manually, is it necessary or is there a "get_variables"-like method?

Answer 1

The answer to question two is ,"mostly yes" and it offers an almost immediate answer to your question:

funcD <- sapply(vars, function(v) D(func, v))
funcDD <- matrix(list(), 2,2)
for (i in 1:length(vars)) 
        funcDD[,i] <- sapply(vars, function(v) D(funcD[[i]], v))
funcDD
#---------
     [,1]       [,2]      
[1,] Expression Expression
[2,] Expression Expression
> funcDD[1,1]
[[1]]
-(sin(x + y) + cos(x - y))

The "mostly" qualification is that one needs to use "list" rather than "expression" as the object type that the matrix is holding. Expressions don't really qualify as atomic objects, and you could easily extract the value and use it as a call, which might even be more convenient than having it as an expression:

> is.expression(funcDD[1,1])
[1] FALSE
> funcDD[1,1][[1]]
-(sin(x + y) + cos(x - y))
> class(funcDD[1,1][[1]])
[1] "call"

Turns out what was wanted was the same structure, so this calls each matrix element with the same specific vector as the evaluation environment and returns them all as a matrix.:

matrix(sapply(funcDD, eval, env=list(x=0, y=pi)), length(vars))
#---------
     [,1] [,2]
[1,]    1   -1
[2,]   -1    1

Answer 2

I think it'd be a lot easier to write a loop which calculates each derivative and places its value directly into a matrix. Thus,

hess<-matrix(nrow=N,ncol=N)  #for x1 thru xN
for(j in 1:N) {
    for(k in 1:N) {
        hess[i,j]<- Dfunc(func,vars[i,j])
        }
    }

Where you'll have to set up your x1,x2,...xN variables in a matrix vars

Answer 3

Here is a function that can return the Hessian of an expression in a few different formats. The code is at the bottom of this answer, preceded by examples of its use.

Example usages

my_fn <- expression((x^2)*(y^2))

# Get the symbolic Hessian as a character matrix

get_hessian(my_fn, as_matrix = TRUE)
#>      [x]              [y]             
#> [x] "2 * (y^2)"       "2 * x * (2 * y)"
#> [y] "2 * x * (2 * y)" "(x^2) * 2"

# Get the symbolic Hessian as a nested list of expressions
get_hessian(my_fn, as_matrix = FALSE)
#> $x
#> $x$x
#> 2 * (y^2)
#> 
#> $x$y
#> 2 * x * (2 * y)
#> 
#> 
#> $y
#> $y$x
#> 2 * x * (2 * y)
#> 
#> $y$y
#> (x^2) * 2

# Get the numeric Hessian from evaluating at a particular point
get_hessian(my_fn, eval_at = list(x = 2, y = 2))
#>      [x] [y]
#> [x]    8   16
#> [y]   16    8

Code for the function

get_hessian <- function(f, as_matrix = FALSE, eval_at = NULL) {

  fn_inputs <- all.vars(f); names(fn_inputs) <- fn_inputs
  n_inputs <- length(fn_inputs)

  # Obtain the symbolic Hessian as a nested list

  result <- lapply(fn_inputs, function(x) lapply(fn_inputs, function(x) NULL))

  for (i in seq_len(n_inputs)) {

    first_deriv <- D(f, fn_inputs[i])

    for (j in seq_len(n_inputs)) {

      second_partial_deriv <- D(first_deriv, fn_inputs[j])

      result[[i]][[j]] <- second_partial_deriv

    }
  }

  # Convert the symbolic Hessian to a character matrix
  if (is.null(eval_at)) {
    if (as_matrix) {
      matrix_result <- matrix(as.character(diag(n_inputs)), nrow = n_inputs, ncol = n_inputs)

      for (i in seq_len(n_inputs)) {
        for (j in seq_len(n_inputs)) {
          matrix_result[i, j] <- gsub("expression", "", format(result[[i]][[j]]), fixed = TRUE)
        }
      }

      dimnames(matrix_result) <- list(fn_inputs, fn_inputs)

      return(matrix_result)

    } else {

      return(result)

    }
  }

  # Evaluate the Hessian at a set point if a named list is provided

  if (!is.null(eval_at)) {
    result_vals <- diag(n_inputs)

    for (i in seq_len(n_inputs)) {
      for (j in seq_len(n_inputs)) {

        result_vals[i, j] <- eval(result[[i]][[j]], envir = eval_at)

      }
    }

    dimnames(matrix_result) <- list(fn_inputs, fn_inputs)

    return(result_vals)
  }
}