Skip to content

Commit

Permalink
Improvements to test_distributions_cholesky
Browse files Browse the repository at this point in the history 
* Create + use expect_lower_tri. Delete expect_upper_tri
* update snapshots to use `[1,,]` instead
  • Loading branch information
@njtierney
njtierney committed Oct 31, 2024
1 parent 0634d16 commit e557efa
Show file tree
Hide file tree
Showing 3 changed files with 61 additions and 153 deletions.
142 changes: 38 additions & 104 deletions tests/testthat/_snaps/distributions_cholesky.md
View file
Original file line number Diff line number Diff line change
@@ -1,128 +1,62 @@
# Cholesky factor of Wishart should be a lower triangular matrix

Code
calculate(chol_x, nsim = 1, seed = 2024 - 7 - 30 - 1431)
calculate(chol_x, nsim = 1, seed = 2024 - 10 - 31 - 1338)$chol_x[1, , ]
Output
$chol_x
, , 1
[,1] [,2] [,3]
[1,] 1.76182 0 0
, , 2
[,1] [,2] [,3]
[1,] -0.005111915 1.734849 0
, , 3
[,1] [,2] [,3]
[1,] -0.9636536 -0.8675692 0.7560725
[,1] [,2] [,3]
[1,] 1.205827 -0.283302 -0.2737789
[2,] 0.000000 1.318010 -2.3508394
[3,] 0.000000 0.000000 0.2704156

---

Code
(calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024 - 7 - 30 - 1431))
calc_chol$x[1, , ]
Output
$x
, , 1
[,1] [,2] [,3]
[1,] 3.104011 -0.009006277 -1.697785
, , 2
[,1] [,2] [,3]
[1,] -0.009006277 3.009727 -1.500175
, , 3
[,1] [,2] [,3]
[1,] -1.697785 -1.500175 2.25295
$chol_x
, , 1
[,1] [,2] [,3]
[1,] 1.76182 0 0
, , 2
[,1] [,2] [,3]
[1,] -0.005111915 1.734849 0
, , 3
[,1] [,2] [,3]
[1,] -0.9636536 -0.8675692 0.7560725
[,1] [,2] [,3]
[1,] 2.5280832 0.8034031 3.4674274
[2,] 0.8034031 4.7851721 -0.8106264
[3,] 3.4674274 -0.8106264 8.1530456

---

Code
calc_chol$chol_x[1, , ]
Output
[,1] [,2] [,3]
[1,] 1.589995 0.5052867 2.1807792
[2,] 0.000000 2.1283462 -0.8986062
[3,] 0.000000 0.0000000 1.6092714

# Cholesky factor of LJK_correlation should be a lower triangular matrix

Code
calculate(chol_x, nsim = 1, seed = 2024 - 7 - 30 - 1431)
calculate(chol_x, nsim = 1, seed = 2024 - 7 - 30 - 1431)$chol_x[1, , ]
Output
$chol_x
, , 1
[,1] [,2] [,3]
[1,] 1 0 0
, , 2
[,1] [,2] [,3]
[1,] -0.1775724 0.9841077 0
, , 3
[,1] [,2] [,3]
[1,] 0.2806787 0.7509681 0.5977177
[,1] [,2] [,3]
[1,] 1 -0.1775724 0.2806787
[2,] 0 0.9841077 0.7509681
[3,] 0 0.0000000 0.5977177

---

Code
(calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024 - 7 - 30 - 1431))
calc_chol$x[1, , ]
Output
[,1] [,2] [,3]
[1,] 1.0000000 -0.1775724 0.2806787
[2,] -0.1775724 1.0000000 0.6891927
[3,] 0.2806787 0.6891927 1.0000000

---

Code
calc_chol$chol_x[1, , ]
Output
$x
, , 1
[,1] [,2] [,3]
[1,] 1 -0.1775724 0.2806787
, , 2
[,1] [,2] [,3]
[1,] -0.1775724 1 0.6891927
, , 3
[,1] [,2] [,3]
[1,] 0.2806787 0.6891927 1
$chol_x
, , 1
[,1] [,2] [,3]
[1,] 1 0 0
, , 2
[,1] [,2] [,3]
[1,] -0.1775724 0.9841077 0
, , 3
[,1] [,2] [,3]
[1,] 0.2806787 0.7509681 0.5977177
[2,] 0 0.9841077 0.7509681
[3,] 0 0.0000000 0.5977177

# Post-MCMC, Wishart distribution stays symmetric, chol remains lower tri

Expand Down
49 changes: 9 additions & 40 deletions tests/testthat/helper-expectations.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,54 +20,23 @@ expect_upper_tri <- function(object){
act$upper_tri <- get_upper_tri2(act$mat)
act$lower_tri <- get_lower_tri(act$mat)

all_upper_zero <- all(act$upper_tri == 0)
all_lower_non_zero <- all(act$lower_tri != 0)
if (all_upper_zero && all_lower_non_zero){
all_lower_zero <- all(act$lower_tri == 0)
all_upper_non_zero <- all(act$upper_tri != 0)
is_upper_tri <- all_lower_zero && all_upper_non_zero
if (is_upper_tri){
succeed()
return(invisible(act$val))
}

if (!all_upper_zero){
vals <- glue::glue_collapse(glue::glue("{round(act$upper_tri, 3)}"), sep = " ")
msg <- glue::glue("{act$lab} is not lower triangular. Values above the \\
main diagonal are not all zero: {vals}")
}

if (!all_lower_non_zero){
if (!all_lower_zero){
vals <- glue::glue_collapse(glue::glue("{round(act$lower_tri, 3)}"), sep = " ")
msg <- glue::glue_collapse(glue::glue("{act$lab} is not lower triangular. Some values below \\
the main diagonal contain zero: {vals}"))
}

fail(msg)

}


expect_lower_tri <- function(object){
act <- quasi_label(rlang::enquo(object), arg = "object")

act$mat <- ga_to_mat(object)

act$upper_tri <- get_upper_tri2(act$mat)
act$lower_tri <- get_lower_tri(act$mat)

all_upper_zero <- all(act$upper_tri == 0)
all_lower_non_zero <- all(act$lower_tri != 0)
if (all_upper_zero && all_lower_non_zero){
succeed()
return(invisible(act$val))
}

if (!all_upper_zero){
vals <- glue::glue_collapse(glue::glue("{round(act$upper_tri, 3)}"), sep = " ")
msg <- glue::glue("{act$lab} is not lower triangular. Values above the \\
msg <- glue::glue("{act$lab} is not upper triangular. Values below the \\
main diagonal are not all zero: {vals}")
}

if (!all_lower_non_zero){
vals <- glue::glue_collapse(glue::glue("{round(act$lower_tri, 3)}"), sep = " ")
msg <- glue::glue_collapse(glue::glue("{act$lab} is not lower triangular. Some values below \\
if (!all_upper_non_zero){
vals <- glue::glue_collapse(glue::glue("{round(act$upper_tri, 3)}"), sep = " ")
msg <- glue::glue_collapse(glue::glue("{act$lab} is not upper triangular. Some values above \\
the main diagonal contain zero: {vals}"))
}

Expand Down
23 changes: 14 additions & 9 deletions tests/testthat/test_distributions_cholesky.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,20 +22,21 @@ test_that("Cholesky factor of Wishart should be a lower triangular matrix", {
calc_x <- calculate(x, nsim = 1)
calc_chol <- calculate(chol_x, nsim = 1)

expect_lower_tri(calc_chol$chol_x)
expect_upper_tri(calc_chol$chol_x)
expect_square(calc_chol$chol_x)

## Test if we do calculate on x and chol_x
x <- wishart(df = 4, Sigma = diag(3))
chol_x <- chol(x)
calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024-10-31-1342)
expect_snapshot(
calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024-10-31-1342)
calc_chol$x[1,,]
)
expect_snapshot(
calc_chol$chol_x[1,,]
)
expect_square(calc_chol$chol_x)
expect_lower_tri(calc_chol$chol_x)
expect_upper_tri(calc_chol$chol_x)
})

test_that("Cholesky factor of LJK_correlation should be a lower triangular matrix", {
Expand All @@ -45,22 +46,26 @@ test_that("Cholesky factor of LJK_correlation should be a lower triangular matri
x <- lkj_correlation(eta = 3, dimension = 3)
chol_x <- chol(x)
expect_snapshot(
calculate(chol_x, nsim = 1, seed = 2024-07-30-1431)
calculate(chol_x, nsim = 1, seed = 2024-07-30-1431)$chol_x[1,,]
)
calc_x <- calculate(x, nsim = 1, seed = 2024-07-30-1431)
calc_chol <- calculate(chol_x, nsim = 1, seed = 2024-07-30-1431)

expect_lower_tri(calc_chol$chol_x)
expect_upper_tri(calc_chol$chol_x)
expect_square(calc_chol$chol_x)

## Test if we do calculate on x and chol_x
x <- lkj_correlation(eta = 3, dimension = 3)
chol_x <- chol(x)
calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024-07-30-1431)
expect_snapshot(
(calc_chol <- calculate(x, chol_x, nsim = 1, seed = 2024-07-30-1431))
calc_chol$x[1,,]
)
expect_snapshot(
calc_chol$chol_x[1,,]
)
expect_square(calc_chol$chol_x)
expect_lower_tri(calc_chol$chol_x)
expect_upper_tri(calc_chol$chol_x)
})

test_that("Post-MCMC, Wishart distribution stays symmetric, chol remains lower tri",{
Expand All @@ -80,7 +85,7 @@ test_that("Post-MCMC, Wishart distribution stays symmetric, chol remains lower t
expect_square(calcs$x)
expect_square(calcs$`chol(x)`)
expect_symmetric(calcs$x)
expect_lower_tri(calcs$`chol(x)`)
expect_upper_tri(calcs$`chol(x)`)

})

Expand All @@ -101,7 +106,7 @@ test_that("Post-MCMC, LKJ distribution stays symmetric, chol remains lower tri",
expect_square(calcs$x)
expect_square(calcs$`chol(x)`)
expect_symmetric(calcs$x)
expect_lower_tri(calcs$`chol(x)`)
expect_upper_tri(calcs$`chol(x)`)

})

Expand Down

0 comments on commit e557efa

Please sign in to comment.