tests/testthat/test-coverage-gaps.R

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

describe("compute_mem RSpectra branch (coverage)", {
  it("uses RSpectra for large matrices when available", {
    skip_if_not_installed("RSpectra")
    n <- 5001
    w <- matrix(0, n, n)
    idx <- cbind(seq_len(n - 1), 2:n)
    w[idx] <- 1
    w <- w + t(w)
    rs <- rowSums(w)
    rs[rs == 0] <- 1
    w <- w / rs

    mem <- compute_mem(w, n)
    expect_true(is.matrix(mem$vectors))
    expect_true(is.numeric(mem$values))
    expect_true(length(mem$values) <= 500)
  })
})

describe("null_moran pair rotation (coverage)", {
  it("exercises pair rotation with degenerate eigenvalues", {
    n <- 6
    angles <- seq(0, 2 * pi, length.out = n + 1)[seq_len(n)]
    coords <- cbind(cos(angles), sin(angles), 0)
    distmat <- as.matrix(dist(coords))
    data <- rnorm(n)

    w <- compute_weight_matrix(distmat)
    mem <- compute_mem(w, n)
    pairs <- make_pairs(mem$values, tol = 1e-6)
    has_pair <- any(vapply(pairs, length, integer(1)) == 2)
    expect_true(has_pair)

    result <- null_moran(
      data, distmat,
      n_perm = 5L, seed = 1, procedure = "pair"
    )
    expect_s3_class(result, "null_distribution")
    expect_equal(result$n_perm, 5)
  })
})

describe("null_spin_hungarian data mismatch (coverage)", {
  it("errors when data length mismatches coords", {
    coords <- list(
      lh = matrix(rnorm(15), ncol = 3),
      rh = matrix(rnorm(15), ncol = 3)
    )
    expect_error(
      null_spin_hungarian(1:5, coords, n_perm = 3L),
      "total parcels"
    )
  })
})

describe("rodrigues rotation (coverage)", {
  it("produces valid rotation matrices", {
    set.seed(42)
    n_lh <- 5
    n_rh <- 5
    coords <- list(
      lh = matrix(rnorm(n_lh * 3), ncol = 3),
      rh = matrix(rnorm(n_rh * 3), ncol = 3)
    )
    data <- rnorm(n_lh + n_rh)

    result <- null_spin_vasa(
      data, coords,
      n_perm = 3L, seed = 1,
      rotation = "rodrigues"
    )
    expect_s3_class(result, "null_distribution")
    expect_equal(result$n_perm, 3)
  })
})

describe("null_burt2020 via generate_nulls with fixed_idx (coverage)", {
  it("exercises fixed_idx path when resample=FALSE", {
    set.seed(42)
    n <- 30
    data <- rnorm(n)
    distmat <- as.matrix(dist(matrix(rnorm(n * 3), ncol = 3)))
    result <- null_burt2020(
      data, distmat,
      n_perm = 3L, seed = 1, ns = 15L, resample = FALSE
    )
    expect_s3_class(result, "null_distribution")
  })
})

describe("neuromaps-registry refresh and cache (coverage)", {
  it("build_neuromaps_registry with refresh=TRUE clears cache", {
    the$registry <- tibble::tibble(source = "stale")
    the$osf_json <- "stale"
    the$meta_json <- "stale"

    mock_fname <- paste0(
      "source-t_desc-m_space-fs",
      "_den-10k_hemi-L_feature.func.gii"
    )

    local_mocked_bindings(
      fetch_neuromaps_osf_json = function() {
        list(annotations = list(
          list(
            source = "t", desc = "m",
            space = "fs", den = "10k", res = NULL,
            hemi = "L", format = "surface",
            fname = mock_fname,
            rel_path = "t/m/fs/",
            checksum = "aaa", tags = list("pet"),
            url = list("4mw3a", "f1")
          )
        ))
      },
      fetch_neuromaps_meta_json = function() {
        list(annotations = list(
          list(
            annot = list(
              source = "t", desc = "m",
              space = "fs", den = "10k"
            ),
            full_desc = "Test",
            demographics = list(N = 10, age = "30")
          )
        ))
      }
    )

    result <- build_neuromaps_registry(refresh = TRUE)
    expect_equal(result$source, "t")

    the$registry <- NULL
    the$osf_json <- NULL
    the$meta_json <- NULL
  })

  it("clear_neuromaps_cache resets all cached data", {
    the$osf_json <- "data"
    the$meta_json <- "data"
    the$registry <- tibble::tibble(source = "cached")

    result <- clear_neuromaps_cache()
    expect_null(the$osf_json)
    expect_null(the$meta_json)
    expect_null(the$registry)
    expect_null(result)
  })
})

describe("read_surface_coordinates (coverage)", {
  it("errors for unsupported format", {
    expect_error(
      read_surface_coordinates("file.obj"),
      "Unsupported"
    )
  })
})

describe("validate_distmat (coverage)", {
  it("errors for non-matrix input", {
    expect_error(
      validate_distmat(1:5, 5),
      "matrix"
    )
  })
})

describe("read_brain_map_values branches (coverage)", {
  it("errors for .surf.gii files", {
    expect_error(
      read_brain_map_values("test.surf.gii"),
      "surface geometry"
    )
  })

  it("errors for unsupported format", {
    expect_error(
      read_brain_map_values("test.xyz"),
      "Unsupported"
    )
  })
})

describe("validate_coords (coverage)", {
  it("errors for non-list input", {
    expect_error(validate_coords("not a list"), "list")
  })

  it("errors for bad lh matrix", {
    coords <- list(
      lh = matrix(1:4, ncol = 2),
      rh = matrix(1:6, ncol = 3)
    )
    expect_error(validate_coords(coords), "3 columns")
  })

  it("errors for bad rh matrix", {
    coords <- list(
      lh = matrix(1:6, ncol = 3),
      rh = matrix(1:4, ncol = 2)
    )
    expect_error(validate_coords(coords), "3 columns")
  })
})

describe("density_to_n unknown density (coverage)", {
  it("errors for unknown density string", {
    expect_error(density_to_n("99k"), "Unknown density")
  })
})

describe("parcellate with file-like args (coverage)", {
  it("parcellate reads brain map values from path", {
    local_mocked_bindings(
      read_brain_map_values = function(path) c(1, 2, 3, 4)
    )
    local_mocked_bindings(
      read_parcellation_labels = function(path) c(1L, 1L, 2L, 2L)
    )

    result <- parcellate("fake_data.func.gii", "fake_parc.label.gii")
    expect_equal(unname(result), c(1.5, 3.5))
  })

  it("unparcellate reads parcellation from path", {
    local_mocked_bindings(
      read_parcellation_labels = function(path) c(1L, 1L, 2L, 2L)
    )

    parcel_data <- c("1" = 10, "2" = 20)
    result <- unparcellate(parcel_data, "fake_parc.label.gii")
    expect_equal(result, c(10, 10, 20, 20))
  })
})

describe("get_parcel_centroids surface and geodesic (coverage)", {
  it("computes geodesic centroids", {
    vertices <- matrix(c(
      0, 0, 0,
      1, 0, 0,
      0, 1, 0,
      1, 1, 0
    ), ncol = 3, byrow = TRUE)
    faces <- matrix(c(1L, 2L, 3L, 2L, 3L, 4L), ncol = 3, byrow = TRUE)
    labels <- c(1, 1, 1, 1)

    centroids <- get_parcel_centroids(
      vertices, labels,
      method = "geodesic", faces = faces
    )
    expect_equal(nrow(centroids), 1)
    expect_equal(ncol(centroids), 3)
  })

  it("errors for invalid vertices", {
    expect_error(
      get_parcel_centroids(matrix(1:4, ncol = 2), c(1, 1)),
      "3 columns"
    )
  })
})

describe("resample_images strategies (coverage)", {
  it("errors for downsample_only with different spaces", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)
    expect_error(
      resample_images(
        src, trg,
        src_space = "fsaverage",
        trg_space = "fsLR",
        strategy = "downsample_only"
      ),
      "same space"
    )
  })

  it("errors for missing target file", {
    src <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    expect_error(
      resample_images(
        src, "nonexistent.gii",
        src_space = "fsaverage",
        trg_space = "fsaverage"
      ),
      "not found"
    )
  })

  it("downsample_only returns same files when equal density", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    local_mocked_bindings(
      get_gifti_density = function(path) "10k"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsaverage",
      strategy = "downsample_only"
    )
    expect_equal(result$src, src)
    expect_equal(result$trg, trg)
  })

  it("downsample_only downsamples source when higher", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    density_call <- 0L
    local_mocked_bindings(
      get_gifti_density = function(path) {
        density_call <<- density_call + 1L
        if (density_call == 1L) "32k" else "10k"
      },
      transform_to_space = function(paths, ...) "resampled.gii"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsaverage",
      strategy = "downsample_only"
    )
    expect_equal(result$src, "resampled.gii")
    expect_equal(result$trg, trg)
  })

  it("downsample_only downsamples target when higher", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    density_call <- 0L
    local_mocked_bindings(
      get_gifti_density = function(path) {
        density_call <<- density_call + 1L
        if (density_call == 1L) "10k" else "32k"
      },
      transform_to_space = function(paths, ...) "resampled.gii"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsaverage",
      strategy = "downsample_only"
    )
    expect_equal(result$src, src)
    expect_equal(result$trg, "resampled.gii")
  })

  it("transform_to_src transforms target to source space", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    local_mocked_bindings(
      get_gifti_density = function(path) "10k",
      transform_to_space = function(...) "resampled.gii"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsLR",
      strategy = "transform_to_src"
    )
    expect_equal(result$src, src)
    expect_equal(result$trg, "resampled.gii")
  })

  it("transform_to_trg transforms source to target space", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    local_mocked_bindings(
      get_gifti_density = function(path) "10k",
      transform_to_space = function(...) "resampled.gii"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsLR",
      strategy = "transform_to_trg"
    )
    expect_equal(result$src, "resampled.gii")
    expect_equal(result$trg, trg)
  })

  it("transform_to_alt transforms both to alt space", {
    src <- withr::local_tempfile(fileext = ".gii")
    trg <- withr::local_tempfile(fileext = ".gii")
    file.create(src)
    file.create(trg)

    local_mocked_bindings(
      get_gifti_density = function(path) "10k",
      transform_to_space = function(...) "resampled.gii"
    )

    result <- resample_images(
      src, trg,
      src_space = "fsaverage",
      trg_space = "fsLR",
      strategy = "transform_to_alt",
      alt_space = "fsaverage",
      alt_density = "32k"
    )
    expect_equal(result$src, "resampled.gii")
    expect_equal(result$trg, "resampled.gii")
  })
})

describe("transform_to_space full path (coverage)", {
  it("transforms a file via ciftiTools mock", {
    skip_if_not_installed("ciftiTools")

    tmp <- withr::local_tempfile(fileext = ".func.gii")
    file.create(tmp)

    local_mocked_bindings(
      check_wb_command = function(...) "/mock/wb_command"
    )
    local_mocked_bindings(
      ciftiTools.setOption = function(...) NULL,
      resample_gifti = function(...) NULL,
      .package = "ciftiTools"
    )

    result <- transform_to_space(
      tmp,
      target_space = "fsLR",
      target_density = "32k",
      method = "barycentric",
      verbose = TRUE
    )
    expect_length(result, 1)
    expect_true(grepl("fsLR_32k", result))
  })

  it("uses adaptive method with area surfaces", {
    skip_if_not_installed("ciftiTools")

    tmp <- withr::local_tempfile(fileext = ".func.gii")
    area_cur <- withr::local_tempfile(fileext = ".surf.gii")
    area_new <- withr::local_tempfile(fileext = ".surf.gii")
    file.create(tmp)
    file.create(area_cur)
    file.create(area_new)

    captured_args <- NULL
    local_mocked_bindings(
      check_wb_command = function(...) "/mock/wb_command"
    )
    local_mocked_bindings(
      ciftiTools.setOption = function(...) NULL,
      resample_gifti = function(...) {
        captured_args <<- list(...)
        NULL
      },
      .package = "ciftiTools"
    )

    result <- transform_to_space(
      tmp,
      target_space = "fsaverage",
      target_density = "10k",
      method = "adaptive",
      area_surf_current = area_cur,
      area_surf_new = area_new,
      verbose = FALSE
    )
    expect_true(grepl("fsaverage_10k", result))
  })
})

describe("check_wb_command ciftiTools path (coverage)", {
  it("returns ciftiTools configured path", {
    skip_if_not_installed("ciftiTools")

    tmp <- withr::local_tempfile()
    file.create(tmp)

    local_mocked_bindings(
      ciftiTools.getOption = function(...) tmp,
      .package = "ciftiTools"
    )

    result <- check_wb_command()
    expect_equal(result, tmp)
  })

  it("falls back to system PATH", {
    skip_if_not_installed("ciftiTools")

    local_mocked_bindings(
      ciftiTools.getOption = function(...) NULL,
      .package = "ciftiTools"
    )

    sys_wb <- Sys.which("wb_command")
    if (nzchar(sys_wb)) {
      result <- check_wb_command()
      expect_true(nzchar(result))
    } else {
      withr::local_envvar(PATH = "")
      expect_error(check_wb_command(), "wb_command")
    }
  })
})

describe("annot_to_gifti full path (coverage)", {
  it("converts annotation file to GIFTI", {
    skip_if_not_installed("freesurferformats")

    tmp_annot <- withr::local_tempfile(fileext = ".annot")
    tmp_out <- withr::local_tempfile(fileext = ".label.gii")

    local_mocked_bindings(
      read.fs.annot = function(path) {
        list(label_codes = c(1L, 2L, 3L, 1L, 2L))
      },
      .package = "freesurferformats"
    )
    local_mocked_bindings(
      write_gifti = function(gii, path) {
        writeLines("mock", path)
      },
      .package = "gifti"
    )

    file.create(tmp_annot)
    result <- annot_to_gifti(tmp_annot, output_path = tmp_out)
    expect_equal(result, tmp_out)
    expect_true(file.exists(tmp_out))
  })

  it("auto-generates output path", {
    skip_if_not_installed("freesurferformats")

    tmp_dir <- withr::local_tempdir()
    tmp_annot <- file.path(tmp_dir, "test.annot")
    file.create(tmp_annot)

    local_mocked_bindings(
      read.fs.annot = function(path) {
        list(label_codes = c(1L, 2L))
      },
      .package = "freesurferformats"
    )
    local_mocked_bindings(
      write_gifti = function(gii, path) {
        writeLines("mock", path)
      },
      .package = "gifti"
    )

    result <- annot_to_gifti(tmp_annot)
    expect_true(grepl("\\.label\\.gii$", result))
  })
})

describe("fsmorph_to_gifti full path (coverage)", {
  it("converts morphometry file to GIFTI", {
    skip_if_not_installed("freesurferformats")

    tmp_morph <- withr::local_tempfile(fileext = ".curv")
    tmp_out <- withr::local_tempfile(fileext = ".func.gii")

    local_mocked_bindings(
      read.fs.morph = function(path) c(0.1, 0.2, 0.3),
      .package = "freesurferformats"
    )
    local_mocked_bindings(
      write_gifti = function(gii, path) {
        writeLines("mock", path)
      },
      .package = "gifti"
    )

    file.create(tmp_morph)
    result <- fsmorph_to_gifti(tmp_morph, output_path = tmp_out)
    expect_equal(result, tmp_out)
    expect_true(file.exists(tmp_out))
  })

  it("auto-generates output path", {
    skip_if_not_installed("freesurferformats")

    tmp_dir <- withr::local_tempdir()
    tmp_morph <- file.path(tmp_dir, "test.curv")
    file.create(tmp_morph)

    local_mocked_bindings(
      read.fs.morph = function(path) c(0.1, 0.2),
      .package = "freesurferformats"
    )
    local_mocked_bindings(
      write_gifti = function(gii, path) {
        writeLines("mock", path)
      },
      .package = "gifti"
    )

    result <- fsmorph_to_gifti(tmp_morph)
    expect_true(grepl("\\.func\\.gii$", result))
  })
})

describe("get_gifti_density with mock (coverage)", {
  it("detects density from vertex count", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(numeric(10242)))
      },
      .package = "gifti"
    )

    result <- get_gifti_density("fake.func.gii")
    expect_equal(result, "10k")
  })

  it("errors for unknown vertex count", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(numeric(999)))
      },
      .package = "gifti"
    )

    expect_error(
      get_gifti_density("fake.func.gii"),
      "Unknown vertex count"
    )
  })
})

describe("parse_neuromaps_filename (coverage)", {
  it("parses BIDS-style filename", {
    result <- parse_neuromaps_filename(
      "source-abagen_desc-genepc1_feature.func.gii"
    )
    expect_equal(result$source, "abagen")
    expect_equal(result$desc, "genepc1")
    expect_equal(result$ext, ".func.gii")
  })
})

describe("neuromaps_cache_dir (coverage)", {
  it("uses option when set", {
    withr::local_options(neuromapr.data_dir = "/tmp/test_cache")
    result <- neuromaps_cache_dir()
    expect_equal(result, "/tmp/test_cache")
  })

  it("uses env var when set", {
    withr::local_options(neuromapr.data_dir = NULL)
    withr::local_envvar(NEUROMAPR_DATA_DIR = "/tmp/env_cache")
    result <- neuromaps_cache_dir()
    expect_equal(result, "/tmp/env_cache")
  })

  it("falls back to R_user_dir", {
    withr::local_options(neuromapr.data_dir = NULL)
    withr::local_envvar(NEUROMAPR_DATA_DIR = "")
    result <- neuromaps_cache_dir()
    expect_true(grepl("neuromapr", result))
  })
})

describe("validate_checksum (coverage)", {
  it("returns TRUE for null expected", {
    expect_true(validate_checksum("anyfile", NULL))
  })

  it("returns TRUE for empty expected", {
    expect_true(validate_checksum("anyfile", ""))
  })
})

describe("compute_knn (coverage)", {
  it("finds k nearest neighbors", {
    dm <- as.matrix(dist(1:5))
    result <- compute_knn(dm, k = 2)
    expect_equal(nrow(result$indices), 5)
    expect_equal(ncol(result$indices), 2)
    expect_equal(result$indices[1, 1], 2L)
    expect_true(all(result$distances > 0))
  })
})

describe("read_surface_coordinates (coverage)", {
  it("reads .surf.gii via gifti", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(matrix(rnorm(12), ncol = 3)))
      },
      .package = "gifti"
    )
    result <- read_surface_coordinates("test.surf.gii")
    expect_true(is.matrix(result))
    expect_equal(ncol(result), 3)
  })

  it("reads plain .gii via gifti", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(matrix(rnorm(12), ncol = 3)))
      },
      .package = "gifti"
    )
    result <- read_surface_coordinates("test.gii")
    expect_true(is.matrix(result))
  })
})

describe("read_brain_map_values .label.gii (coverage)", {
  it("reads .label.gii files", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(c(1L, 2L, 3L)))
      },
      .package = "gifti"
    )
    result <- read_brain_map_values("test.label.gii")
    expect_equal(result, c(1, 2, 3))
  })

  it("reads generic .gii files", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(c(0.5, 1.5, 2.5)))
      },
      .package = "gifti"
    )
    result <- read_brain_map_values("test_data.gii")
    expect_equal(result, c(0.5, 1.5, 2.5))
  })
})

describe("read_brain_map_values NIfTI (coverage)", {
  it("reads .nii.gz files", {
    skip_if_not_installed("RNifti")
    local_mocked_bindings(
      readNifti = function(path) array(1:8, dim = c(2, 2, 2)),
      .package = "RNifti"
    )
    result <- read_brain_map_values("test.nii.gz")
    expect_equal(result, as.numeric(1:8))
  })

  it("reads .nii files", {
    skip_if_not_installed("RNifti")
    local_mocked_bindings(
      readNifti = function(path) array(1:4, dim = c(2, 2)),
      .package = "RNifti"
    )
    result <- read_brain_map_values("test.nii")
    expect_equal(result, as.numeric(1:4))
  })
})

describe("null_baum NA branch (coverage)", {
  it("produces NA when rotated labels are all zero", {
    n_lh <- 3
    n_rh <- 3
    coords <- list(
      lh = matrix(rnorm(n_lh * 3), ncol = 3),
      rh = matrix(rnorm(n_rh * 3), ncol = 3)
    )
    parcellation <- c(1, 0, 0, 0, 0, 2)
    data <- c("1" = 10, "2" = 20)

    local_mocked_bindings(
      rotate_coords = function(...) {
        lh_rot <- array(0, dim = c(n_lh, 3, 1))
        rh_rot <- array(0, dim = c(n_rh, 3, 1))
        list(lh = lh_rot, rh = rh_rot)
      }
    )

    result <- null_baum(
      data, coords, parcellation,
      n_perm = 1L, seed = 1
    )
    expect_s3_class(result, "null_distribution")
    expect_true(any(is.na(result$nulls)))
  })
})

describe("null_cornblath NA branch (coverage)", {
  it("produces NA when no valid nearest labels", {
    n_lh <- 5
    n_rh <- 5
    coords <- list(
      lh = matrix(rnorm(n_lh * 3), ncol = 3),
      rh = matrix(rnorm(n_rh * 3), ncol = 3)
    )
    parcellation <- c(1, 1, 1, 0, 0, 0, 0, 0, 2, 2)
    data <- c("1" = 10, "2" = 20)

    local_mocked_bindings(
      rotate_coords = function(...) {
        list(
          lh = array(0, dim = c(n_lh, 3, 1)),
          rh = array(0, dim = c(n_rh, 3, 1))
        )
      },
      nearest_valid_label = function(rotated, original, labels, valid) {
        rep(0L, length(labels))
      }
    )

    result <- null_cornblath(
      data, coords, parcellation,
      n_perm = 1L, seed = 1
    )
    expect_s3_class(result, "null_distribution")
  })
})

describe("read_parcellation_labels (coverage)", {
  it("reads labels from GIFTI file", {
    local_mocked_bindings(
      read_gifti = function(path) {
        list(data = list(c(1L, 2L, 3L, 1L)))
      },
      .package = "gifti"
    )
    result <- read_parcellation_labels("fake.label.gii")
    expect_equal(result, c(1L, 2L, 3L, 1L))
  })
})