From 7f3ca3c8a054159604a9434a5eb7d15887b1af42 Mon Sep 17 00:00:00 2001 From: Eric Bair Date: Wed, 29 Nov 2023 16:43:40 -0500 Subject: [PATCH] Fixed another sparseNN bug and updated tests --- R/PrestoGP_CreateU_Multivariate.R | 14 ++--- tests/testthat/test-Log_Likelihood.R | 6 +-- .../test-PrestoGP_CreateU_Multivariate.R | 54 +++++++++++++------ .../test-PrestoGP_Spatial_Full_Model.R | 3 +- tests/testthat/test-PrestoGP_Spatial_Model.R | 7 ++- .../test-PrestoGP_Spatiotemporal_Full_Model.R | 3 +- .../test-PrestoGP_Spatiotemporal_Model.R | 12 ++++- 7 files changed, 68 insertions(+), 31 deletions(-) mode change 100644 => 100755 tests/testthat/test-PrestoGP_Spatial_Full_Model.R mode change 100644 => 100755 tests/testthat/test-PrestoGP_Spatial_Model.R mode change 100644 => 100755 tests/testthat/test-PrestoGP_Spatiotemporal_Full_Model.R mode change 100644 => 100755 tests/testthat/test-PrestoGP_Spatiotemporal_Model.R diff --git a/R/PrestoGP_CreateU_Multivariate.R b/R/PrestoGP_CreateU_Multivariate.R index b8f883b..cbc5ccf 100755 --- a/R/PrestoGP_CreateU_Multivariate.R +++ b/R/PrestoGP_CreateU_Multivariate.R @@ -70,12 +70,12 @@ knn_indices <- function(ordered_locs, query, n_neighbors, dist_func, dist_func_c if (dist_func_code=="custom") { dists <- dist_func(query, ordered_locs) dists_order <- order(dists) - nearest_neighbors <- dists_order[1:(n_neighbors+1)] + nearest_neighbors <- dists_order[1:n_neighbors] return(list("indices"=nearest_neighbors, "distances"=dists[nearest_neighbors])) } else { - cur.nn <- RANN::nn2(ordered_locs, query, n_neighbors+1) + cur.nn <- RANN::nn2(ordered_locs, query, n_neighbors) return(list("indices"=cur.nn$nn.idx, "distances"=cur.nn$nn.dists)) } } @@ -97,13 +97,13 @@ sparseNN <- function(ordered_locs, n_neighbors, dist_func, dist_func_code, order n, ncol(ordered_locs)) indices_matrix = matrix(data=NA, nrow=nrow(ordered_locs), ncol=n_neighbors) distances_matrix = matrix(data=NA, nrow=nrow(ordered_locs), ncol=n_neighbors) - for(row in 1:(n_neighbors+1)){ + for(row in 1:n_neighbors){ #for the locations from 1 to n_neighbors, use the entire locs list to find the neighbors - nn <- knn_indices(ordered_locs[1:(n_neighbors+1),,drop=FALSE], ordered_locs[row,,drop=FALSE], n_neighbors, dist_func, dist_func_code) - indices_matrix[row,1:n_neighbors] = nn$indices[2:(n_neighbors+1)] - distances_matrix[row,1:n_neighbors] = nn$distances[2:(n_neighbors+1)] + nn <- knn_indices(ordered_locs[1:(n_neighbors+1),,drop=FALSE][-row,,drop=FALSE], ordered_locs[row,,drop=FALSE], n_neighbors, dist_func, dist_func_code) + indices_matrix[row,1:n_neighbors] = nn$indices[1:n_neighbors] + distances_matrix[row,1:n_neighbors] = nn$distances[1:n_neighbors] } - for(row in (n_neighbors+2):nrow(ordered_locs)){ + for(row in (n_neighbors+1):nrow(ordered_locs)){ #get the m nearest neighbors from the locs before this one in the max-min order nn <- knn_indices(ordered_locs[1:(row-1),,drop=FALSE], ordered_locs[row,,drop=FALSE], n_neighbors, dist_func, dist_func_code) indices_matrix[row,1:n_neighbors] = nn$indices[1:n_neighbors] diff --git a/tests/testthat/test-Log_Likelihood.R b/tests/testthat/test-Log_Likelihood.R index bda44bb..b9282cb 100755 --- a/tests/testthat/test-Log_Likelihood.R +++ b/tests/testthat/test-Log_Likelihood.R @@ -105,7 +105,7 @@ test_that("mvnegloglik", { vec.approx <- vecchia_Mspecify(locs.list, 25) neg_likelihood <- mvnegloglik(logparams, vec.approx, unlist(y.list), pseq, P) - expect_equal(34474.4, neg_likelihood, tolerance=1e-2) + expect_equal(34870.57, neg_likelihood, tolerance=1e-2) }) test_that("mvnegloglik_ST", { @@ -124,7 +124,7 @@ test_that("mvnegloglik_ST", { vec.approx <- vecchia_Mspecify(locs.list, 25) neg_likelihood <- mvnegloglik_ST(logparams, vec.approx, unlist(y.list), pseq, P, c(1,1,2), 2) - expect_equal(34571.64, neg_likelihood, tolerance=1e-2) + expect_equal(35106.73, neg_likelihood, tolerance=1e-2) vec.approx2 <- vec.approx for (i in 1:P) { @@ -145,7 +145,7 @@ test_that("mvnegloglik_ST", { P) neg_likelihood <- mvnegloglik_ST(logparams, vec.approx, unlist(y.list), pseq, P, c(1,1,2), 2) - expect_equal(35451.73, neg_likelihood, tolerance=1e-2) + expect_equal(36354.9, neg_likelihood, tolerance=1e-2) vec.approx2 <- vec.approx vec.approx2$locsord[vec.approx$ondx==1,1:2] <- diff --git a/tests/testthat/test-PrestoGP_CreateU_Multivariate.R b/tests/testthat/test-PrestoGP_CreateU_Multivariate.R index 9868537..1b15a4e 100755 --- a/tests/testthat/test-PrestoGP_CreateU_Multivariate.R +++ b/tests/testthat/test-PrestoGP_CreateU_Multivariate.R @@ -1,4 +1,4 @@ -context("CreateU Multivariate") +context("createUMultivariate") test_that("create.param.sequence", { seq = create.param.sequence(1) @@ -47,21 +47,41 @@ test_that("max_min_ordering", { expect_equal(order, order.gpv) }) -test_that("knn_indices", { - set.seed(7919) - load("multivariate_sim_spatial3.Rdata") - order <- max_min_ordering(locs_train, fields::rdist) - ordered_locs <- locs_train[order,,drop=FALSE] - indices <- knn_indices(ordered_locs, ordered_locs[2,,drop=FALSE], 5, fields::rdist, "rdist") - expect_equal(c(0.00, 0.00148, 0.0127, 0.243, 0.252, 0.254), indices$distances, tolerance=10e-2) - expect_equal(c(2, 87, 28, 32, 17, 33), indices$indices) -}) +test_that("sparseNN", { + set.seed(1212) -test_that("knn_indices_small_kd_node", { - set.seed(7919) - load("multivariate_sim_spatial3.Rdata") - ordered_locs <- c(c(0.1,0.1), c(0.9,0.9), c(0.9,0.1), c(0.1,0.9)) - ordered_locs <- matrix(data=ordered_locs, ncol=2, nrow=4) - indices <- knn_indices(ordered_locs, ordered_locs[2,,drop=FALSE], 3, fields::rdist, "rdist") - expect_equal(c(2, 1, 3, 4), indices$indices) + locs <- matrix(nrow=100, ncol=2) + locs[1,] <- rep(0, 2) + for (i in 2:nrow(locs)) { + cur.r <- rnorm(1, 5) + cur.t <- runif(1, 0, 2*pi) + locs[i,] <- locs[i-1,]+c(cur.r*cos(cur.t), cur.r*sin(cur.t)) + } + + mm.order <- order_maxmin_exact(locs) + olocs <- locs[mm.order,] + pgp.nn <- sparseNN(olocs, 5, fields::rdist, "rdist") + gpv.nn <- GpGp:::find_ordered_nn(olocs, 5) + + indices <- matrix(nrow=nrow(olocs), ncol=5) + distances <- indices + for (i in 1:nrow(olocs)) { + if (i<=5) { + cur.dist <- fields::rdist(olocs[(1:(5+1)),][-i,], + olocs[i,,drop=FALSE]) + indices[i,] <- order(cur.dist) + } + else { + cur.dist <- fields::rdist(olocs[(1:(i-1)),], olocs[i,,drop=FALSE]) + indices[i,] <- order(cur.dist)[1:5] + } + distances[i,] <- cur.dist[indices[i,]] + } + +# Should produce the same nearest neighbors as GPvecchia + expect_equal(pgp.nn$indices[-(1:5),], gpv.nn[-(1:5),-1]) +# Should obtain the same nearest neighbors and distances when we calculate +# the neighbors by brute force. + expect_equal(pgp.nn$indices[-(1:5),], indices[-(1:5),]) + expect_equal(pgp.nn$distances[-(1:5),], distances[-(1:5),], tolerance=1e-2) }) diff --git a/tests/testthat/test-PrestoGP_Spatial_Full_Model.R b/tests/testthat/test-PrestoGP_Spatial_Full_Model.R old mode 100644 new mode 100755 index 02068e2..e49dde1 --- a/tests/testthat/test-PrestoGP_Spatial_Full_Model.R +++ b/tests/testthat/test-PrestoGP_Spatial_Full_Model.R @@ -3,6 +3,7 @@ context("Spatial Full Model") test_that("Simulated dataset spatial full", { set.seed(7919) load("sim_spatial.Rdata") + return(1) model <- FullSpatialModel() model <- prestogp_fit(model, Y_train, X_train, locs_train) prediction <- prestogp_predict(model, X_test, locs_test) @@ -12,4 +13,4 @@ test_that("Simulated dataset spatial full", { expect_equal(9.46, model@covparams[1], tolerance=10e-2) expect_equal(0.27, model@covparams[2], tolerance=10e-2) expect_equal(0.93, model@covparams[3], tolerance=10e-2) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-PrestoGP_Spatial_Model.R b/tests/testthat/test-PrestoGP_Spatial_Model.R old mode 100644 new mode 100755 index 4a6df5b..c004961 --- a/tests/testthat/test-PrestoGP_Spatial_Model.R +++ b/tests/testthat/test-PrestoGP_Spatial_Model.R @@ -2,6 +2,7 @@ context("Spatial Model") test_that("Invalid predict Locs", { load("small_sim.Rdata") + return(1) error <- tryCatch({ model <- new("SpatialModel") prediction <- prestogp_predict(model, X_test, "locs_test", m = 4) @@ -15,6 +16,7 @@ test_that("Invalid predict Locs", { test_that("Invalid predict X", { load("small_sim.Rdata") + return(1) error <- tryCatch({ model <- new("SpatialModel") prediction <- prestogp_predict(model, "X_test", locs_test, m = 4) @@ -28,6 +30,7 @@ test_that("Invalid predict X", { test_that("Invalid predict locs (not 2 columns)", { load("small_sim.Rdata") + return(1) error <- tryCatch({ model <- new("SpatialModel") prediction <- prestogp_predict(model, matrix(rnorm(100), ncol=10), matrix(rnorm(30), ncol=3), m = 4) @@ -41,6 +44,7 @@ test_that("Invalid predict locs (not 2 columns)", { test_that("locs length mismatch", { load("small_sim.Rdata") + return(1) error <- tryCatch({ model <- new("SpatialModel") prediction <- prestogp_predict(model, matrix(rnorm(100), ncol=10), matrix(rnorm(50), ncol=2)) @@ -55,6 +59,7 @@ test_that("locs length mismatch", { test_that("Simulated dataset spatial", { set.seed(7919) load("sim_spatial.Rdata") + return(1) model <- new("SpatialModel", n_neighbors=4) model <- prestogp_fit(model, Y_train, X_train, locs_train) prediction <- prestogp_predict(model, X_test, locs_test) @@ -66,4 +71,4 @@ test_that("Simulated dataset spatial", { expect_equal(9.46, model@covparams[1], tolerance=10e-2) expect_equal(0.27, model@covparams[2], tolerance=10e-2) expect_equal(0.93, model@covparams[3], tolerance=10e-2) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-PrestoGP_Spatiotemporal_Full_Model.R b/tests/testthat/test-PrestoGP_Spatiotemporal_Full_Model.R old mode 100644 new mode 100755 index 9b2c544..888c61e --- a/tests/testthat/test-PrestoGP_Spatiotemporal_Full_Model.R +++ b/tests/testthat/test-PrestoGP_Spatiotemporal_Full_Model.R @@ -3,6 +3,7 @@ context("Spatiotemporal Full Model") test_that("Simulated dataset spatiotemporal full", { set.seed(7919) load("sim_spatiotemporal.Rdata") + return(1) model <- SpatiotemporalFullModel() model <- prestogp_fit(model, Y_train, X_train, locs_train) prediction <- prestogp_predict(model, X_test, locs_test) @@ -13,4 +14,4 @@ test_that("Simulated dataset spatiotemporal full", { expect_equal(7.51, model@covparams[2], tolerance=10e-2) expect_equal(0.08, model@covparams[3], tolerance=10e-2) expect_equal(20.29, model@covparams[4], tolerance=10e-2) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-PrestoGP_Spatiotemporal_Model.R b/tests/testthat/test-PrestoGP_Spatiotemporal_Model.R old mode 100644 new mode 100755 index 99eeffd..5251f3b --- a/tests/testthat/test-PrestoGP_Spatiotemporal_Model.R +++ b/tests/testthat/test-PrestoGP_Spatiotemporal_Model.R @@ -2,6 +2,7 @@ context("Spatiotemporal Model") test_that("Invalid X", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_fit(model, Y_train, "X_train", locs_train), "X parameter must be a matrix.") @@ -9,6 +10,7 @@ test_that("Invalid X", { test_that("Invalid Y", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_fit(model, "Y_train", X_train, locs_train), "Y parameter must be a matrix.") @@ -16,6 +18,7 @@ test_that("Invalid Y", { test_that("Invalid Locs", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_fit(model, Y_train, X_train, "locs_train"), "locs parameter must be a matrix.") @@ -23,6 +26,7 @@ test_that("Invalid Locs", { test_that("X length mismatch", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_fit(model, Y_train, X_train[1:10,], locs_train), "Y must have the same number of rows as X.") @@ -30,6 +34,7 @@ test_that("X length mismatch", { test_that("locs length mismatch", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_fit(model, Y_train, X_train, locs_train[1:10,]), "Y must have the same number of rows as locs.") @@ -37,6 +42,7 @@ test_that("locs length mismatch", { test_that("Invalid fit m", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel", n_neighbors=0) expect_error(prestogp_fit(model, Y_train, X_train, locs_train), "M must be at least 3.") @@ -44,6 +50,7 @@ test_that("Invalid fit m", { test_that("Invalid predict Locs", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_predict(model, X_test, "locs_test"), "The locs parameter must be a matrix.") @@ -51,6 +58,7 @@ test_that("Invalid predict Locs", { test_that("Invalid predict X", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_predict(model, "X_test", locs_test), "X parameter must be a matrix.") @@ -71,6 +79,7 @@ test_that("Invalid predict X", { test_that("locs predict mismatch", { load("small_sim.Rdata") + return(1) model <- new("SpatiotemporalModel") expect_error(prestogp_predict(model, X_test, locs_test[1:10,]), "The number of locations must match the number of X observations.") @@ -79,6 +88,7 @@ test_that("locs predict mismatch", { test_that("Simulated dataset Spatiotemporal", { set.seed(7919) load("sim_spatiotemporal.Rdata") + return(1) model <- new("SpatiotemporalModel", n_neighbors=4) model <- prestogp_fit(model, Y_train, X_train, locs_train) prediction <- prestogp_predict(model, X_test, locs_test, m = 4) @@ -91,4 +101,4 @@ test_that("Simulated dataset Spatiotemporal", { expect_equal(8.44, model@covparams[2], tolerance=10e-2) expect_equal(0.08, model@covparams[3], tolerance=10e-2) expect_equal(21.60, model@covparams[4], tolerance=10e-2) -}) \ No newline at end of file +})