tests/testthat/test-cross-validation.R

In neuromapr: Spatial Null Models and Transforms for Brain Map Comparison

describe("cross-validation with Python reference", {
  skip_if_no_python_fixtures()

  inputs <- load_python_fixture("shared_inputs")
  n <- inputs$n
  distmat <- as.matrix(inputs$distmat)
  data <- inputs$data
  data_y <- inputs$data_y

  describe("weight matrix (inverse distance)", {
    ref <- load_python_fixture("weight_matrix_inverse_distance")

    it("matches Python output", {
      w <- compute_weight_matrix(distmat, kernel = "inverse_distance")
      expect_equal(w, as.matrix(ref$w), tolerance = 1e-10)
    })
  })

  describe("weight matrix (exponential)", {
    ref <- load_python_fixture("weight_matrix_exponential")

    it("matches Python output", {
      w <- compute_weight_matrix(distmat, kernel = "exponential")
      expect_equal(w, as.matrix(ref$w), tolerance = 1e-10)
    })
  })

  describe("SAR weight matrix", {
    ref <- load_python_fixture("sar_weight_matrix")

    it("matches Python output", {
      w <- build_sar_weights(distmat, ref$d0)
      expect_equal(w, as.matrix(ref$w), tolerance = 1e-10)
    })

    it("has zero diagonal", {
      w <- build_sar_weights(distmat, ref$d0)
      expect_equal(diag(w), rep(0, n))
    })

    it("has unit row sums", {
      w <- build_sar_weights(distmat, ref$d0)
      expect_equal(rowSums(w), rep(1, n), tolerance = 1e-10)
    })
  })

  describe("MEM eigendecomposition", {
    ref <- load_python_fixture("mem")
    w <- compute_weight_matrix(distmat, kernel = "inverse_distance")
    mem <- compute_mem(w, n)

    it("eigenvalues match", {
      r_vals <- sort(mem$values, decreasing = TRUE)
      py_vals <- sort(ref$eigenvalues, decreasing = TRUE)
      min_len <- min(length(r_vals), length(py_vals))
      expect_equal(
        r_vals[seq_len(min_len)],
        py_vals[seq_len(min_len)],
        tolerance = 1e-8
      )
    })

    it("eigenvectors match up to sign", {
      r_vecs <- mem$vectors
      py_vecs <- as.matrix(ref$eigenvectors)
      min_cols <- min(ncol(r_vecs), ncol(py_vecs))

      r_order <- order(mem$values, decreasing = TRUE)
      py_order <- order(ref$eigenvalues, decreasing = TRUE)
      r_vecs <- r_vecs[, r_order[seq_len(min_cols)], drop = FALSE]
      py_vecs <- py_vecs[, py_order[seq_len(min_cols)], drop = FALSE]

      for (j in seq_len(min_cols)) {
        same_sign <- sum((r_vecs[, j] - py_vecs[, j])^2)
        flip_sign <- sum((r_vecs[, j] + py_vecs[, j])^2)
        expect_lt(min(same_sign, flip_sign), 1e-8)
      }
    })
  })

  describe("Moran double-centered matrix", {
    ref <- load_python_fixture("moran_double_centered")

    it("matches Python output", {
      w <- compute_weight_matrix(distmat, kernel = "inverse_distance")
      sym_w <- (w + t(w)) / 2
      row_means <- rowMeans(sym_w)
      grand_mean <- mean(row_means)
      dbl_r <- sym_w - outer(row_means, row_means, "+") + grand_mean
      expect_equal(dbl_r, as.matrix(ref$dbl), tolerance = 1e-10)
    })
  })

  describe("variogram computation", {
    ref <- load_python_fixture("variogram")

    it("matches Python output with fixed indices", {
      idx_r <- sort(ref$idx) + 1L
      vg <- compute_variogram(
        data,
        distmat,
        nh = ref$nh,
        pv = ref$pv,
        ns = ref$ns,
        idx = idx_r
      )
      expect_equal(vg$gamma, ref$gamma, tolerance = 1e-10)
      expect_equal(vg$distance, ref$bin_centers, tolerance = 1e-10)
    })
  })

  describe("ZYZ Euler rotation matrix", {
    ref <- load_python_fixture("rotation_matrix")

    it("matches Python output for fixed angles", {
      alpha <- ref$alpha
      beta <- ref$beta
      gamma <- ref$gamma
      ca <- cos(alpha)
      sa <- sin(alpha)
      cb <- cos(beta)
      sb <- sin(beta)
      cg <- cos(gamma)
      sg <- sin(gamma)

      rot <- matrix(
        c(
          # nolint: object_name
          cg * cb * ca - sg * sa,
          sg * cb * ca + cg * sa,
          -sb * ca,
          -cg * cb * sa - sg * ca,
          -sg * cb * sa + cg * ca,
          sb * sa,
          cg * sb,
          sg * sb,
          cb
        ),
        nrow = 3,
        ncol = 3
      )

      expect_equal(rot, as.matrix(ref$R), tolerance = 1e-12)
    })
  })

  describe("cost matrix", {
    ref <- load_python_fixture("cost_matrix")

    it("matches Python output", {
      original <- as.matrix(ref$original)
      rotated <- as.matrix(ref$rotated)
      cost <- compute_cost_matrix(original, rotated)
      expect_equal(cost, as.matrix(ref$cost), tolerance = 1e-10)
    })
  })

  describe("rank matching", {
    ref <- load_python_fixture("rank_match")

    it("matches Python output", {
      matched <- rank_match(ref$surrogate, ref$target)
      expect_equal(matched, ref$matched)
    })
  })

  describe("correlations", {
    ref <- load_python_fixture("correlation_reference")

    it("Pearson r matches Python", {
      r_val <- cor(data, data_y, method = "pearson")
      expect_equal(r_val, ref$pearson_r, tolerance = 1e-6)
    })

    it("Spearman r matches Python", {
      r_val <- cor(data, data_y, method = "spearman")
      expect_equal(r_val, ref$spearman_r, tolerance = 1e-6)
    })

    it("compare_maps r matches Python", {
      result <- compare_maps(data, data_y, verbose = FALSE)
      expect_equal(result$r, ref$pearson_r, tolerance = 1e-6)
    })
  })

  describe("null distribution statistics", {
    ref <- load_python_fixture("null_distribution_stats")

    it("SAR null correlations have similar distribution", {
      sar_r <- null_burt2018(data, distmat, n_perm = ref$n_perm, seed = 1L)
      sar_surr <- as.matrix(sar_r)
      null_r <- apply(sar_surr, 2, function(s) cor(s, data_y))
      expect_equal(mean(null_r), ref$sar_null_r_mean, tolerance = 0.15)
      expect_equal(sd(null_r), ref$sar_null_r_std, tolerance = 0.15)
    })

    it("SAR surrogates preserve rank distribution", {
      expect_true(ref$sar_rank_preserved)
    })

    it("Moran null correlations have similar distribution", {
      moran_r <- null_moran(
        data, distmat,
        n_perm = ref$n_perm, seed = 1L, procedure = "singleton"
      )
      moran_surr <- as.matrix(moran_r)
      null_r <- apply(moran_surr, 2, function(s) cor(s, data_y))
      expect_equal(mean(null_r), ref$moran_null_r_mean, tolerance = 0.15)
      expect_equal(sd(null_r), ref$moran_null_r_std, tolerance = 0.15)
    })
  })

  describe("burt2020 surrogate properties", {
    it("preserves rank distribution", {
      skip_if(
        !file.exists(file.path(fixture_dir(), "burt2020_stats.json")),
        paste(
          "burt2020 stats fixture not available",
          "(brainsmash not installed in Python)"
        )
      )
      ref <- load_python_fixture("burt2020_stats")
      expect_true(ref$rank_preserved)
    })
  })
})