tests/testthat/helper-expectations.R

In greta-dev/greta: Simple and Scalable Statistical Modelling in R

ga_to_mat <- function(ga) {
  mat_nrow <- mat_ncol <- ncol(ga)
  matrix(ga, nrow = mat_nrow, ncol = mat_nrow, byrow = TRUE)
}
# ga_to_mat(calc_chol$chol_x)

get_upper_tri2 <- function(mat) {
  mat[upper.tri(mat)]
}

get_lower_tri <- function(mat) {
  mat[lower.tri(mat)]
}

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

  act$mat <- object[1, , ]

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

  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_lower_zero) {
    vals <- glue::glue_collapse(
      glue::glue("{round(act$lower_tri, 3)}"),
      sep = " "
    )
    msg <- glue::glue(
      "{act$lab} is not upper triangular. Values below the \\
    main diagonal are not all zero: {vals}"
    )
  }

  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}"
    ))
  }

  fail(msg)
}

expect_square <- function(object) {
  # 1. Capture object and label
  act <- quasi_label(rlang::enquo(object), arg = "object")

  # 2. Call expect()
  act$nrow <- dim(act$val[1, , ])[1]
  act$ncol <- dim(act$val[1, , ])[2]
  expect(
    ok = act$nrow == act$ncol,
    failure_message = glue::glue(
      "{act$lab} has dim {act$nrow}x{act$ncol}, and is not square."
    )
  )

  # 3. Invisibly return the value
  invisible(act$val)
}

# expect_square(calc_chol$chol_x)
# expect_square(array(data = 1:9, c(1,3,3)))
# expect_square(array(data = 1:12, c(1,3,4)))

expect_symmetric <- function(object) {
  # 1. Capture object and label
  act <- quasi_label(rlang::enquo(object), arg = "object")

  act$mat <- ga_to_mat(object)

  act$upper <- get_upper_tri2(act$mat)
  act$lower <- get_lower_tri(act$mat)

  # 2. Call expect()
  expect(
    ok = all.equal(act$upper, act$lower),
    failure_message = glue::glue("{act$lab} is not symmetric")
  )

  # 3. Invisibly return the value
  invisible(act$val)
}

# xmat <- calculate(x, nsim = 1)[[1]] |> ga_to_mat()
#
# xmat
#
# expect_symmetric(calculate(x, nsim = 1)[[1]])
#
# all.equal(get_lower_tri(xmat),get_upper_tri2(xmat))