tests/testthat/test-kernels.R

In MagmaClustR: Clustering and Prediction using Multi-Task Gaussian Processes with Common Mean

test_that("Squared Exponential kernel works for null distance", {
  hp <- tibble::tibble(se_variance = 1, se_lengthscale = 1)

  se_kernel(2, 2, hp)[1] %>% expect_equal(exp(1))
})

test_that("Periodic kernel works for null distance", {
  hp <- tibble::tibble(perio_variance = 1, perio_lengthscale = 1, period = 1)

  perio_kernel(2, 2, hp)[1] %>% expect_equal(exp(1))
})

test_that("Rational quadratic kernel works for null distance", {
  hp <- tibble::tibble(rq_variance = 1, rq_lengthscale = 1, rq_scale = 1)

  rq_kernel(2, 2, hp)[1] %>% expect_equal(exp(1))
})

test_that("Linear kernel works for null distance", {
  hp <- tibble::tibble(lin_slope = 1, lin_offset = 1)

  lin_kernel(0, 2, hp)[1] %>% expect_equal(exp(1))
})

test_that("gradients for the Squared Exponential kernel are valid", {
  hp <- tibble::tibble(se_variance = 1, se_lengthscale = 1)
  hp_v <- tibble::tibble(se_variance = 1 + 10^(-8), se_lengthscale = 1)
  hp_l <- tibble::tibble(se_variance = 1, se_lengthscale = 1 + 10^(-8))

  deriv_v <- se_kernel(c(1, 2), c(2, 3), hp, "se_variance")
  deriv_l <- se_kernel(c(1, 2), c(2, 3), hp, "se_lengthscale")

  emp_deriv_v <- (se_kernel(c(1, 2), c(2, 3), hp_v)[1] -
    se_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_l <- (se_kernel(c(1, 2), c(2, 3), hp_l)[1] -
    se_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)

  round(deriv_v, 4) %>% expect_equal(round(emp_deriv_v, 4))
  round(deriv_l, 4) %>% expect_equal(round(emp_deriv_l, 4))
})

test_that("gradients for the Periodic kernel are valid", {
  hp <- tibble::tibble(
    perio_variance = 1,
    perio_lengthscale = 1, period = pi
  )
  hp_v <- tibble::tibble(
    perio_variance = 1 + 10^(-8),
    perio_lengthscale = 1, period = pi
  )
  hp_l <- tibble::tibble(
    perio_variance = 1,
    perio_lengthscale = 1 + 10^(-8), period = pi
  )
  hp_p <- tibble::tibble(
    perio_variance = 1,
    perio_lengthscale = 1, period = pi + 10^(-8)
  )

  deriv_v <- perio_kernel(c(1, 2), c(2, 3), hp, "perio_variance")
  deriv_l <- perio_kernel(c(1, 2), c(2, 3), hp, "perio_lengthscale")
  deriv_p <- perio_kernel(c(1, 2), c(2, 3), hp, "period")

  emp_deriv_v <- (perio_kernel(c(1, 2), c(2, 3), hp_v)[1] -
    perio_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_l <- (perio_kernel(c(1, 2), c(2, 3), hp_l)[1] -
    perio_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_p <- (perio_kernel(c(1, 2), c(2, 3), hp_p)[1] -
    perio_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)

  round(deriv_v, 4) %>% expect_equal(round(emp_deriv_v, 4))
  round(deriv_l, 4) %>% expect_equal(round(emp_deriv_l, 4))
  round(deriv_p, 4) %>% expect_equal(round(emp_deriv_p, 4))
})

test_that("gradients for the Rational Quadratic kernel are valid", {
  hp <- tibble::tibble(rq_variance = 1, rq_lengthscale = 1, rq_scale = 1)
  hp_v <- tibble::tibble(
    rq_variance = 1 + 10^(-8),
    rq_lengthscale = 1, rq_scale = 1
  )
  hp_l <- tibble::tibble(
    rq_variance = 1,
    rq_lengthscale = 1 + 10^(-8), rq_scale = 1
  )
  hp_s <- tibble::tibble(
    rq_variance = 1,
    rq_lengthscale = 1, rq_scale = 1 + 10^(-8)
  )

  deriv_v <- rq_kernel(c(1, 2), c(2, 3), hp, "rq_variance")
  deriv_l <- rq_kernel(c(1, 2), c(2, 3), hp, "rq_lengthscale")
  deriv_s <- rq_kernel(c(1, 2), c(2, 3), hp, "rq_scale")

  emp_deriv_v <- (rq_kernel(c(1, 2), c(2, 3), hp_v)[1] -
    rq_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_l <- (rq_kernel(c(1, 2), c(2, 3), hp_l)[1] -
    rq_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_s <- (rq_kernel(c(1, 2), c(2, 3), hp_s)[1] -
    rq_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)

  round(deriv_v, 4) %>% expect_equal(round(emp_deriv_v, 4))
  round(deriv_l, 4) %>% expect_equal(round(emp_deriv_l, 4))
  round(deriv_s, 4) %>% expect_equal(round(emp_deriv_s, 4))
})

test_that("gradients for the Linear kernel are valid", {
  hp <- tibble::tibble(lin_slope = 1, lin_intercept = 1, lin_offset = 1)
  hp_s <- tibble::tibble(
    lin_slope = 1 + 10^(-8),
    lin_intercept = 1, lin_offset = 1
  )
  hp_o <- tibble::tibble(
    lin_slope = 1,
    lin_intercept = 1, lin_offset = 1 + 10^(-8)
  )

  deriv_s <- lin_kernel(c(1, 2), c(2, 3), hp, "lin_slope") %>% as.vector()
  deriv_o <- lin_kernel(c(1, 2), c(2, 3), hp, "lin_offset")

  emp_deriv_s <- (lin_kernel(c(1, 2), c(2, 3), hp_s)[1] -
    lin_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)
  emp_deriv_o <- (lin_kernel(c(1, 2), c(2, 3), hp_o)[1] -
    lin_kernel(c(1, 2), c(2, 3), hp)[1]) / 10^(-8)

  round(deriv_s, 4) %>% expect_equal(round(emp_deriv_s, 4))
  round(deriv_o, 4) %>% expect_equal(round(emp_deriv_o, 4))
})