tests/testthat/test-SpatPCA.R

In SpatPCA: Regularized Principal Component Analysis for Spatial Data

# generate 1-D data with a given seed
Sys.setenv(RCPP_PARALLEL_BACKEND = "tinythread")
set.seed(1234)
tol <- 1e-6
num_cores <- 2

x_1D <- as.matrix(seq(-5, 5, length = 10))
Phi_1D <- exp(-x_1D ^ 2) / norm(exp(-x_1D ^ 2), "F")
Y_1D <- {
  rnorm(n = 100, sd = 3) %*% t(Phi_1D) +
    matrix(rnorm(n = 100 * 10), 100, 10)
}

cv_1D <- spatpca(x = x_1D, Y = Y_1D, num_cores = num_cores)
cv_1D_fixed_K_multiple_tau2 <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 1,
  tau2 = c(0, 1),
  num_cores = num_cores
)
cv_1D_fixed_K_multiple_gamma <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 1,
  gamma = c(0, 1),
  num_cores = num_cores
)
cv_1D_fixed_K_fixed_tau1_fixed_tau2 <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 1,
  tau1 = 10,
  tau2 = 100,
  num_cores = num_cores
)
cv_1D_fixed_K_fixed_tau1_fixed_tau2_multiple_gamma <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 1,
  tau1 = 0,
  tau2 = 0,
  gamma = c(0, 0.5, 1),
  num_cores = num_cores
)
cv_1D_fixed_K_fixed_tau1 <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 1,
  tau1 = 10,
  num_cores = num_cores
)
estimated_eigenvalue_large_gamma <-
  spatialPrediction(
    cv_1D_fixed_K_fixed_tau1$eigenfn,
    cv_1D_fixed_K_fixed_tau1$detrended_Y,
    1000,
    cv_1D_fixed_K_fixed_tau1$eigenfn
  )$eigenvalue

estimated_signle_eigenvalue_medium_gamma <-
  spatialPrediction(
    cv_1D_fixed_K_fixed_tau1$eigenfn,
    cv_1D_fixed_K_fixed_tau1$detrended_Y,
    5,
    cv_1D_fixed_K_fixed_tau1$eigenfn
  )$eigenvalue

cv_1D_fixed_K_zero_tau1_zero_tau2 <- spatpca(
  x = x_1D,
  Y = Y_1D,
  K = 5,
  tau1 = 0,
  tau2 = 0,
  num_cores = num_cores
)
estimated_eigenvalue_small_gamma <- spatialPrediction(
  cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn,
  cv_1D_fixed_K_zero_tau1_zero_tau2$detrended_Y,
  0.5,
  cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn
)$eigenvalue

estimated_eigenvalue_medium_gamma <- spatialPrediction(
  cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn,
  cv_1D_fixed_K_zero_tau1_zero_tau2$detrended_Y,
  10,
  cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn
)$eigenvalue


used_number_cores <-
  as.integer(Sys.getenv("RCPP_PARALLEL_NUM_THREADS", ""))
expected_selected_tau1_R_3.6_higher <- 0.00046416
expected_selected_tau1_R_3.6_lower <- 0.01169
expected_selected_gamma_R_3.6_higher <- 0.44503397
expected_selected_gamma_R_3.6_lower <- 0.4737518

# Test
test_that("Selected tuning parameters", {
  expect_lte(min(
    abs(cv_1D$selected_tau1 - expected_selected_tau1_R_3.6_higher),
    abs(cv_1D$selected_tau1 - expected_selected_tau1_R_3.6_lower)
  ),
  tol)
  expect_lte(abs(cv_1D$selected_tau2 - 0), tol)
  expect_lte(min(
    abs(
      cv_1D$selected_gamma - expected_selected_gamma_R_3.6_higher
    ),
    abs(cv_1D$selected_gamma - expected_selected_gamma_R_3.6_lower)
  ),
  tol)
  expect_null(cv_1D$selected_K)
  expect_equal(cv_1D_fixed_K_multiple_tau2$selected_K, 1)
  expect_lte(abs(cv_1D_fixed_K_multiple_tau2$selected_tau1 - 0.002154435),
             tol)
  expect_equal(cv_1D_fixed_K_multiple_tau2$selected_tau2, 1)
  expect_equal(cv_1D_fixed_K_multiple_gamma$selected_gamma, 0)
  expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2$selected_tau1, 10)
  expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2$selected_tau2, 100)
  expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2_multiple_gamma$selected_gamma,
               0)
  expect_equal(cv_1D_fixed_K_fixed_tau1$selected_tau1, 10)
  expect_equal(sum(cv_1D_fixed_K_fixed_tau1$cv_score_tau1), 0)
  expect_equal(sum(estimated_eigenvalue_large_gamma), 0)
  expect_equal(sum(estimated_eigenvalue_medium_gamma), 0)
  expect_lte(abs(sum(estimated_eigenvalue_small_gamma) - 9.397599), tol)
  expect_lte(sum(estimated_signle_eigenvalue_medium_gamma) - 0.1066821,
             tol)
})


# Test environment settings
test_that("Number of threads", {
  expect_equal(num_cores, used_number_cores)
})

test_that("cross-validation plot", {
  expect_error(plot.spatpca("test"),
               cat("Invalid object! Please enter a `spatpca` object"))
  expect_true("ggplot" %in% class(plot.spatpca(cv_1D)))
})

# Test `predict`
x_1Dnew <- as.matrix(seq(6, 7, length = 4))
prediction <- predict(cv_1D, x_new = x_1Dnew)
dominant_pattern_on_new_sites <-
  predictEigenfunction(cv_1D, x_new = x_1Dnew)

test_that("prediction", {
  expect_equal(ncol(prediction), 4)
  expect_equal(nrow(dominant_pattern_on_new_sites), 4)
})


# Test auxiliary function - CV with selecting K
set.seed(1234)
M <- 3
shuffle_split <- sample(rep(1:M, length.out = nrow(Y_1D)))
tau1 <- setTau1(NULL, M)
tau2 <- setTau2(NULL, M)
l2 <- setL2(tau2)
setCores(2)
cv_with_k_seleted <-
  spatpcaCVWithSelectedK(x_1D, Y_1D, M, tau1, tau2, 1, shuffle_split, 10, 1e-04, l2)

test_that("auxiliary function for selecting K", {
  expect_equal(cv_with_k_seleted$selected_K, 1)
  expect_equal(cv_with_k_seleted$cv_result$selected_gamma, 1)
  expect_equal(cv_with_k_seleted$cv_result$selected_tau1, 1)
  expect_equal(cv_with_k_seleted$cv_result$selected_tau2, 0)
})


# 3-D
set.seed(1234)
p <- 4
x <- y <- z <- as.matrix(seq(-5, 5, length = p))
d <- expand.grid(x, y, z)
Phi_3D <-
  rowSums(exp(-d ^ 2)) / norm(as.matrix(rowSums(exp(-d ^ 2))), "F")
Y_3D <-
  rnorm(n = 100, sd = 3) %*% t(Phi_3D) + matrix(rnorm(n = 100 * p ^ 3), 100, p ^
                                                  3)
cv_3D <- spatpca(x = d, Y = Y_3D, num_cores = 2)
predict <-
  eigenFunction(matrix(c(0, 0, 0), 1, 3), as.matrix(d), cv_3D$eigenfn)

test_that("3D case", {
  expect_equal(dim(cv_3D$eigenfn), c(64, 2))
  expect_lte(sum(abs(predict - c(
    0.232199, 0.007501031
  ))), tol)
})