tests/testthat/test-mixture.R

In algebraic.dist: Algebra over Probability Distributions

# Tests for the mixture distribution class

# --- Construction tests ---

test_that("mixture constructor creates valid object with valid args", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 2)
  m <- mixture(list(n1, n2), c(0.3, 0.7))

  expect_s3_class(m, "mixture")
  expect_s3_class(m, "dist")
  expect_length(m$components, 2)
  expect_equal(m$weights, c(0.3, 0.7))
})

test_that("mixture with empty components errors", {
  expect_error(mixture(list(), numeric(0)),
               "'components' must be a non-empty list")
})

test_that("mixture with mismatched weights length errors", {
  n1 <- normal()
  n2 <- normal(mu = 1)
  expect_error(mixture(list(n1, n2), c(0.5, 0.3, 0.2)),
               "'weights' must be a numeric vector of length 2")
})

test_that("mixture with negative weights errors", {
  n1 <- normal()
  n2 <- normal(mu = 1)
  expect_error(mixture(list(n1, n2), c(-0.3, 1.3)),
               "'weights' must be non-negative")
})

test_that("mixture with weights not summing to 1 errors", {
  n1 <- normal()
  n2 <- normal(mu = 1)
  expect_error(mixture(list(n1, n2), c(0.3, 0.3)),
               "'weights' must sum to 1")
})

test_that("mixture with non-dist components errors", {
  expect_error(mixture(list(1, 2), c(0.5, 0.5)),
               "all components must be 'dist' objects")
})

test_that("class hierarchy for continuous univariate mixture", {
  n1 <- normal(mu = 0, var = 1)
  e1 <- exponential(rate = 2)
  m <- mixture(list(n1, e1), c(0.5, 0.5))

  expect_s3_class(m, "mixture")
  expect_s3_class(m, "univariate_dist")
  expect_s3_class(m, "continuous_dist")
  expect_s3_class(m, "dist")
})

test_that("class hierarchy for non-homogeneous components omits sub-types", {
  # A univariate continuous component mixed with a discrete one should

  # not inherit either continuous_dist or discrete_dist
  n1 <- normal(mu = 0, var = 1)
  ed <- empirical_dist(c(1, 2, 3))
  m <- mixture(list(n1, ed), c(0.5, 0.5))

  expect_s3_class(m, "mixture")
  expect_s3_class(m, "univariate_dist")
  expect_s3_class(m, "dist")
  expect_false(inherits(m, "continuous_dist"))
  expect_false(inherits(m, "discrete_dist"))
})

# --- is_mixture ---

test_that("is_mixture works", {
  n1 <- normal()
  n2 <- normal(mu = 3)
  m <- mixture(list(n1, n2), c(0.5, 0.5))

  expect_true(is_mixture(m))
  expect_false(is_mixture(n1))
  expect_false(is_mixture("mixture"))
})

# --- mean ---

test_that("mean() is weighted sum of means", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 10, var = 1)
  m <- mixture(list(n1, n2), c(0.3, 0.7))

  expected_mean <- 0.3 * 0 + 0.7 * 10
  expect_equal(mean(m), expected_mean)
})

test_that("mean() with equal weights is average of component means", {
  e1 <- exponential(rate = 1)
  e2 <- exponential(rate = 0.5)
  m <- mixture(list(e1, e2), c(0.5, 0.5))

  expected_mean <- 0.5 * (1/1) + 0.5 * (1/0.5)
  expect_equal(mean(m), expected_mean)
})

# --- vcov ---

test_that("vcov() uses law of total variance", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 10, var = 4)
  w <- c(0.3, 0.7)
  m <- mixture(list(n1, n2), w)

  comp_means <- c(0, 10)
  comp_vars <- c(1, 4)
  overall_mean <- sum(w * comp_means)
  within_var <- sum(w * comp_vars)
  between_var <- sum(w * (comp_means - overall_mean)^2)
  expected_var <- within_var + between_var

  expect_equal(vcov(m), expected_var)
})

test_that("vcov() of equal normals equals component variance", {
  # Same normal mixed with itself: variance = component variance
  n1 <- normal(mu = 5, var = 3)
  m <- mixture(list(n1, n1), c(0.4, 0.6))

  # between_var = 0 since all means are the same
  # within_var = 3
  expect_equal(vcov(m), 3)
})

# --- density ---

test_that("density() is weighted sum of component densities at several points", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  w <- c(0.3, 0.7)
  m <- mixture(list(n1, n2), w)

  f <- density(m)
  f1 <- density(n1)
  f2 <- density(n2)

  test_points <- c(-3, -1, 0, 2.5, 5, 8)
  for (t in test_points) {
    expected <- w[1] * f1(t) + w[2] * f2(t)
    expect_equal(f(t), expected, tolerance = 1e-12,
                 label = paste("density at t =", t))
  }
})

test_that("density() handles log argument", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))
  f <- density(m)

  val <- f(2.5)
  log_val <- f(2.5, log = TRUE)
  expect_equal(log_val, log(val), tolerance = 1e-12)
})

test_that("density() is vectorized over t", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 3, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))
  f <- density(m)

  ts <- c(-1, 0, 1, 2, 3, 4)
  result <- f(ts)
  expect_length(result, length(ts))

  # Check each element matches scalar call
  for (i in seq_along(ts)) {
    expect_equal(result[i], f(ts[i]), tolerance = 1e-12)
  }
})

# --- cdf ---

test_that("cdf() is weighted sum of component CDFs", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  w <- c(0.3, 0.7)
  m <- mixture(list(n1, n2), w)

  F_mix <- cdf(m)
  F1 <- cdf(n1)
  F2 <- cdf(n2)

  test_points <- c(-3, 0, 2.5, 5, 8)
  for (q in test_points) {
    expected <- w[1] * F1(q) + w[2] * F2(q)
    expect_equal(F_mix(q), expected, tolerance = 1e-12,
                 label = paste("CDF at q =", q))
  }
})

test_that("cdf() is vectorized over q", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))
  F_mix <- cdf(m)

  qs <- c(-2, 0, 2, 4, 6)
  result <- F_mix(qs)
  expect_length(result, length(qs))
})

# --- sampler ---

test_that("sampler() gives correct number of samples", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))

  samp_fn <- sampler(m)
  expect_type(samp_fn, "closure")

  samples <- samp_fn(100)
  expect_length(samples, 100)
  expect_type(samples, "double")
})

test_that("sampler() mean near theoretical mixture mean", {
  set.seed(42)
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 10, var = 1)
  w <- c(0.3, 0.7)
  m <- mixture(list(n1, n2), w)

  samples <- sampler(m)(50000)
  sample_mean <- sum(samples) / length(samples)
  expected_mean <- 0.3 * 0 + 0.7 * 10
  expect_equal(sample_mean, expected_mean, tolerance = 0.1)
})

# --- params ---

test_that("params() concatenates component params and weights", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 2)
  w <- c(0.3, 0.7)
  m <- mixture(list(n1, n2), w)

  p <- params(m)
  expect_true(is.numeric(p))

  # Should contain mu and var from both normals plus the 2 weights
  expect_true("mu" %in% names(p) || "mu1" %in% names(p) || any(grepl("mu", names(p))))
  expect_true(any(grepl("weight", names(p))))
  expect_equal(length(p), 2 + 2 + 2)  # 2 params each + 2 weights
})

# --- nparams ---

test_that("nparams() counts correctly", {
  n1 <- normal(mu = 0, var = 1)
  e1 <- exponential(rate = 2)
  m <- mixture(list(n1, e1), c(0.5, 0.5))

  # normal has 2 params, exponential has 1, plus 2 weights = 5
  expect_equal(nparams(m), 5)
})

# --- dim ---

test_that("dim() returns correct value", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))

  expect_equal(dim(m), 1)
})

# --- sup ---

test_that("sup() spans all component supports", {
  e1 <- exponential(rate = 1)
  n1 <- normal(mu = 0, var = 1)
  m <- mixture(list(e1, n1), c(0.5, 0.5))

  s <- sup(m)
  expect_s3_class(s, "interval")

  # Normal has support (-Inf, Inf), exponential has (0, Inf)
  # So mixture support should be (-Inf, Inf)
  expect_equal(s$infimum(), -Inf)
  expect_equal(s$supremum(), Inf)
})

test_that("sup() with bounded distributions", {
  # Two exponentials: both (0, Inf)
  e1 <- exponential(rate = 1)
  e2 <- exponential(rate = 2)
  m <- mixture(list(e1, e2), c(0.5, 0.5))

  s <- sup(m)
  expect_equal(s$infimum(), 0)
  expect_equal(s$supremum(), Inf)
})

# --- format and print ---

test_that("format() works", {
  n1 <- normal()
  n2 <- normal(mu = 5)
  m <- mixture(list(n1, n2), c(0.5, 0.5))

  fmt <- format(m)
  expect_type(fmt, "character")
  expect_true(grepl("Mixture", fmt))
  expect_true(grepl("2 components", fmt))
})

test_that("format() shows correct number of components", {
  n1 <- normal()
  n2 <- normal(mu = 3)
  n3 <- exponential(rate = 1)
  m <- mixture(list(n1, n2, n3), c(0.2, 0.3, 0.5))

  expect_true(grepl("3 components", format(m)))
})

test_that("print() works", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 5, var = 2)
  m <- mixture(list(n1, n2), c(0.3, 0.7))

  expect_output(print(m), "Mixture distribution")
  expect_output(print(m), "w=0.300")
  expect_output(print(m), "w=0.700")
})

# --- Bimodal density test ---

test_that("mixture of 2 normals has bimodal density", {
  n1 <- normal(mu = -5, var = 1)
  n2 <- normal(mu = 5, var = 1)
  m <- mixture(list(n1, n2), c(0.5, 0.5))

  f <- density(m)

  # Density at the two modes should be higher than at the midpoint
  dens_mode1 <- f(-5)
  dens_mode2 <- f(5)
  dens_midpoint <- f(0)

  expect_gt(dens_mode1, dens_midpoint)
  expect_gt(dens_mode2, dens_midpoint)
})

# --- Mixture of exponentials: CDF between component CDFs ---

test_that("mixture of exponentials: CDF between component CDFs", {
  e1 <- exponential(rate = 1)
  e2 <- exponential(rate = 3)
  m <- mixture(list(e1, e2), c(0.5, 0.5))

  F_mix <- cdf(m)
  F1 <- cdf(e1)
  F2 <- cdf(e2)

  test_points <- c(0.1, 0.5, 1, 2, 5)
  for (t in test_points) {
    val <- F_mix(t)
    lo <- min(F1(t), F2(t))
    hi <- max(F1(t), F2(t))
    expect_true(val >= lo - 1e-12 && val <= hi + 1e-12,
                label = paste("CDF at t =", t, "is between component CDFs"))
  }
})

# --- Edge cases ---

test_that("mixture with a single component behaves like that component", {
  n1 <- normal(mu = 3, var = 2)
  m <- mixture(list(n1), 1)

  expect_equal(mean(m), 3)
  expect_equal(vcov(m), 2)

  f_mix <- density(m)
  f_n1 <- density(n1)
  expect_equal(f_mix(1), f_n1(1), tolerance = 1e-12)
  expect_equal(f_mix(5), f_n1(5), tolerance = 1e-12)
})

test_that("mixture with zero weight on a component ignores it", {
  n1 <- normal(mu = 0, var = 1)
  n2 <- normal(mu = 100, var = 1)
  m <- mixture(list(n1, n2), c(1, 0))

  expect_equal(mean(m), 0)
  expect_equal(vcov(m), 1)
})

test_that("mixture weights tolerance allows tiny numerical error", {
  n1 <- normal()
  n2 <- normal(mu = 1)
  # Weights that sum to 1 within tolerance
  w <- c(1/3, 2/3)
  expect_no_error(mixture(list(n1, n2), w))
})

# --- Multivariate mixture tests ---

test_that("multivariate mixture sampler returns correct shape", {
  set.seed(42)
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(5, 5), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  samp_fn <- sampler(mix)
  samples <- samp_fn(100)
  expect_true(is.matrix(samples))
  expect_equal(nrow(samples), 100)
  expect_equal(ncol(samples), 2)
})

test_that("multivariate mixture vcov returns correct covariance matrix", {
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(4, 4), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  V <- vcov(mix)
  expect_true(is.matrix(V))
  expect_equal(nrow(V), 2)
  expect_equal(ncol(V), 2)
  # Within-component variance: 0.5 * I + 0.5 * I = I
  # Between-component variance: 0.5 * outer(c(-2,-2), c(-2,-2)) +
  #                              0.5 * outer(c(2,2), c(2,2)) = 4 * ones
  # Total diagonal should be 1 + 4 = 5
  expect_equal(V[1, 1], 5, tolerance = 1e-10)
  expect_equal(V[2, 2], 5, tolerance = 1e-10)
  expect_equal(V[1, 2], 4, tolerance = 1e-10)
})

test_that("multivariate mixture inherits multivariate_dist class", {
  m1 <- mvn(mu = c(0, 0))
  m2 <- mvn(mu = c(1, 1))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  expect_s3_class(mix, "multivariate_dist")
})


# ---- marginal.mixture tests ----

test_that("marginal of MVN mixture returns mixture of marginals", {
  m1 <- mvn(mu = c(0, 10), sigma = diag(2))
  m2 <- mvn(mu = c(5, 20), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.3, 0.7))

  # Marginal over first variable
  marg <- marginal(mix, 1)
  expect_true(is_mixture(marg))
  expect_equal(length(marg$components), 2)
  expect_equal(marg$weights, c(0.3, 0.7))

  # Components should be univariate normals
  expect_true(is_normal(marg$components[[1]]))
  expect_true(is_normal(marg$components[[2]]))
  expect_equal(mean(marg$components[[1]]), 0)
  expect_equal(mean(marg$components[[2]]), 5)
})

test_that("marginal of MVN mixture: mean matches", {
  m1 <- mvn(mu = c(1, 2), sigma = diag(2))
  m2 <- mvn(mu = c(3, 4), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  marg <- marginal(mix, 1)
  # Mean of marginal = 0.5*1 + 0.5*3 = 2
  expect_equal(mean(marg), 2)
})

test_that("marginal of 3D MVN mixture keeps 2 components", {
  m1 <- mvn(mu = c(1, 2, 3), sigma = diag(3))
  m2 <- mvn(mu = c(4, 5, 6), sigma = diag(3))
  mix <- mixture(list(m1, m2), c(0.4, 0.6))

  marg <- marginal(mix, c(1, 3))
  expect_true(is_mixture(marg))
  expect_true(is_mvn(marg$components[[1]]))
  expect_equal(dim(marg$components[[1]]), 2)
})


# ---- conditional.mixture tests ----

test_that("conditional of MVN mixture: weights update via Bayes rule", {
  # Two well-separated 2D MVN components
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(10, 10), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  # Condition on X2 = 0 — strongly favors component 1
  result <- conditional(mix, given_indices = 2, given_values = 0)
  expect_true(is_mixture(result))
  expect_true(result$weights[1] > 0.99)  # Component 1 dominates
})

test_that("conditional of MVN mixture: components are correct", {
  sigma <- matrix(c(1, 0.5, 0.5, 1), 2, 2)
  m1 <- mvn(mu = c(0, 0), sigma = sigma)
  m2 <- mvn(mu = c(5, 5), sigma = sigma)
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  result <- conditional(mix, given_indices = 2, given_values = 0)
  # Both components should be univariate normals (result of conditioning 2D MVN)
  expect_true(is_normal(result$components[[1]]))
  expect_true(is_normal(result$components[[2]]))
})

test_that("conditional.mixture with equal weights and symmetric conditioning", {
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(0, 0), sigma = 4 * diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  # Condition on X2 = 0 — both have same marginal mean for X2
  result <- conditional(mix, given_indices = 2, given_values = 0)
  expect_true(is_mixture(result))
  # Component 1 has density dnorm(0,0,1), component 2 has dnorm(0,0,2)
  # w1 ~ 0.5 * dnorm(0,0,1), w2 ~ 0.5 * dnorm(0,0,2)
  # dnorm(0,0,1) = 0.3989, dnorm(0,0,2) = 0.1995
  expect_true(result$weights[1] > result$weights[2])
})

test_that("conditional.mixture P fallback works", {
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(5, 5), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  set.seed(42)
  result <- conditional(mix, P = function(x) x[1] > 3)
  expect_s3_class(result, "empirical_dist")
})

test_that("conditional.mixture errors: no P or given_indices", {
  m1 <- mvn(mu = c(0, 0), sigma = diag(2))
  m2 <- mvn(mu = c(1, 1), sigma = diag(2))
  mix <- mixture(list(m1, m2), c(0.5, 0.5))

  expect_error(conditional(mix), "must provide either")
})