Nothing
# 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)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.