Nothing
make_test_atlas <- function() {
sf_geom <- sf::st_sf(
label = c("lh_frontal", "lh_parietal", "rh_frontal", "lh_unknown"),
view = c("lateral", "lateral", "medial", "lateral"),
geometry = sf::st_sfc(
make_polygon(),
sf::st_polygon(list(matrix(
c(2, 2, 4, 2, 4, 4, 2, 2),
ncol = 2,
byrow = TRUE
))),
sf::st_polygon(list(matrix(
c(5, 5, 8, 5, 8, 8, 5, 5),
ncol = 2,
byrow = TRUE
))),
sf::st_polygon(list(matrix(
c(0, 0, 10, 0, 10, 10, 0, 0),
ncol = 2,
byrow = TRUE
)))
)
)
core <- data.frame(
hemi = c("left", "left", "right"),
region = c("frontal", "parietal", "frontal"),
label = c("lh_frontal", "lh_parietal", "rh_frontal")
)
palette <- c(
lh_frontal = "#FF0000",
lh_parietal = "#00FF00",
rh_frontal = "#0000FF"
)
vertices <- data.frame(
label = c("lh_frontal", "lh_parietal", "rh_frontal")
)
vertices$vertices <- list(1L:3L, 4L:6L, 7L:9L)
ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
palette = palette,
data = ggseg_data_cortical(geom = sf_geom, vertices = vertices)
)
}
make_multiview_atlas <- function() {
make_view_poly <- function(x_off, y_off, size = 1) {
sf::st_polygon(list(matrix(
c(
x_off,
y_off,
x_off + size,
y_off,
x_off + size,
y_off + size,
x_off,
y_off
),
ncol = 2,
byrow = TRUE
)))
}
core_labels <- c(
"lh_frontal",
"lh_parietal",
"lh_temporal",
"lh_occipital",
"lh_insula",
"rh_frontal",
"rh_parietal",
"rh_temporal",
"rh_occipital",
"rh_insula"
)
small_labels <- c("lh_insula", "rh_insula")
ctx <- c("ctx_left", "ctx_left", "ctx_right")
views <- c("axial_1", "axial_2", "sagittal")
sf_labels <- character(0)
sf_views <- character(0)
geoms <- list()
for (v_idx in seq_along(views)) {
x_base <- (v_idx - 1) * 40
for (i in seq_along(core_labels)) {
sz <- if (core_labels[i] %in% small_labels) 0.5 else 2
sf_labels <- c(sf_labels, core_labels[i])
sf_views <- c(sf_views, views[v_idx])
geoms <- c(geoms, list(make_view_poly(x_base + (i - 1) * 3, 0, sz)))
}
sf_labels <- c(sf_labels, ctx[v_idx])
sf_views <- c(sf_views, views[v_idx])
geoms <- c(geoms, list(make_view_poly(x_base, 5, 4)))
}
sf_geom <- sf::st_sf(
label = sf_labels,
view = sf_views,
geometry = sf::st_sfc(geoms)
)
core <- data.frame(
hemi = c(rep("left", 5), rep("right", 5)),
region = rep(
c("frontal", "parietal", "temporal", "occipital", "insula"),
2
),
label = core_labels
)
palette <- setNames(
c(
"#FF0000",
"#00FF00",
"#0000FF",
"#FFFF00",
"#FF00FF",
"#00FFFF",
"#800000",
"#008000",
"#000080",
"#808000"
),
core_labels
)
ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
palette = palette,
data = ggseg_data_cortical(geom = sf_geom)
)
}
make_cortical_hemi_atlas <- function() {
make_view_poly <- function(x_off, y_off, size = 1) {
sf::st_polygon(list(matrix(
c(
x_off,
y_off,
x_off + size,
y_off,
x_off + size,
y_off + size,
x_off,
y_off
),
ncol = 2,
byrow = TRUE
)))
}
lh_labels <- c("lh_frontal", "lh_parietal")
rh_labels <- c("rh_frontal", "rh_parietal")
views <- c("lateral", "medial")
sf_labels <- character(0)
sf_views <- character(0)
geoms <- list()
for (v in views) {
for (i in seq_along(lh_labels)) {
sf_labels <- c(sf_labels, lh_labels[i])
sf_views <- c(sf_views, v)
x <- (match(v, views) - 1) * 20 + (i - 1) * 3
geoms <- c(geoms, list(make_view_poly(x, 0, 2)))
}
for (i in seq_along(rh_labels)) {
sf_labels <- c(sf_labels, rh_labels[i])
sf_views <- c(sf_views, v)
x <- (match(v, views) - 1) * 20 + 10 + (i - 1) * 3
geoms <- c(geoms, list(make_view_poly(x, 0, 2)))
}
}
sf_geom <- sf::st_sf(
label = sf_labels,
view = sf_views,
geometry = sf::st_sfc(geoms)
)
core <- data.frame(
hemi = c("left", "left", "right", "right"),
region = c("frontal", "parietal", "frontal", "parietal"),
label = c(lh_labels, rh_labels)
)
palette <- c(
lh_frontal = "#FF0000",
lh_parietal = "#00FF00",
rh_frontal = "#0000FF",
rh_parietal = "#FFFF00"
)
ggseg_atlas(
atlas = "test_cortical",
type = "cortical",
core = core,
palette = palette,
data = ggseg_data_cortical(geom = sf_geom)
)
}
# atlas_regions ----
describe("atlas_regions", {
it("extracts sorted unique regions from brain_atlas", {
atlas <- make_test_atlas()
result <- atlas_regions(atlas)
expect_identical(result, c("frontal", "parietal"))
})
it("excludes context-only geometry (labels in sf but not in core)", {
atlas <- make_test_atlas()
result <- atlas_regions(atlas)
expect_false("unknown" %in% result)
})
it("works with data.frame", {
df <- data.frame(region = c("frontal", "parietal", "frontal"))
result <- atlas_regions(df)
expect_identical(result, c("frontal", "parietal"))
})
it("works with ggseg_atlas", {
atlas <- make_test_atlas()
result <- atlas_regions(atlas)
expect_true("frontal" %in% result)
expect_true("parietal" %in% result)
})
})
# atlas_labels ----
describe("atlas_labels", {
it("extracts sorted unique labels from brain_atlas", {
atlas <- make_test_atlas()
result <- atlas_labels(atlas)
expect_identical(result, c("lh_frontal", "lh_parietal", "rh_frontal"))
})
it("excludes NA labels", {
core <- data.frame(
hemi = c("left", "left"),
region = c("frontal", "unknown"),
label = c("lh_frontal", NA)
)
vertices <- data.frame(label = c("lh_frontal", NA))
vertices$vertices <- list(1L:3L, 4L:6L)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
expect_identical(atlas_labels(atlas), "lh_frontal")
})
})
# atlas_views ----
describe("atlas_views", {
it("returns unique view names", {
atlas <- make_multiview_atlas()
result <- atlas_views(atlas)
expect_identical(result, c("axial_1", "axial_2", "sagittal"))
})
it("reads views from polygons when sf is absent", {
atlas <- make_test_atlas()
atlas$data$sf <- NULL
expect_identical(atlas_views(atlas), c("lateral", "medial"))
})
it("returns NULL when no 2D data", {
atlas <- make_test_atlas()
atlas$data$geom <- NULL
expect_null(atlas_views(atlas))
})
})
# atlas_type ----
describe("atlas_type", {
it("returns type from brain_atlas", {
atlas <- make_test_atlas()
expect_identical(atlas_type(atlas), "cortical")
})
})
# get_uniq ----
describe("get_uniq", {
it("returns sorted unique values excluding NA", {
df <- data.frame(region = c("c", "a", "b", NA, "a"), label = 1:5)
expect_identical(get_uniq(df, "region"), c("a", "b", "c"))
})
it("errors with invalid type", {
expect_error(get_uniq(data.frame(), "invalid"))
})
})
# guess_type ----
describe("guess_type", {
it("guesses cortical from medial/lateral views", {
df <- data.frame(type = NA, view = c("medial", "lateral"))
expect_warning(
result <- guess_type(df),
"attempting to guess"
)
expect_identical(result, "cortical")
})
it("guesses subcortical when no medial/lateral views", {
df <- data.frame(type = NA, view = c("axial", "sagittal"))
expect_warning(
result <- guess_type(df),
"attempting to guess"
)
expect_identical(result, "subcortical")
})
})
# atlas_region_remove ----
describe("atlas_region_remove", {
it("removes matching regions from core, palette, sf, and vertices", {
atlas <- make_test_atlas()
result <- atlas_region_remove(atlas, "parietal")
expect_false("lh_parietal" %in% result$core$label)
expect_false("lh_parietal" %in% names(result$palette))
expect_false("lh_parietal" %in% result$data$geom$label)
expect_false("lh_parietal" %in% result$data$vertices$label)
})
it("matches on label when specified", {
atlas <- make_test_atlas()
result <- atlas_region_remove(atlas, "^lh_f", match_on = "label")
expect_false("lh_frontal" %in% result$core$label)
expect_identical(nrow(result$core), 2L)
})
it("preserves NA regions in core", {
atlas <- make_test_atlas()
atlas$core$region[1] <- NA
result <- atlas_region_remove(atlas, "nonexistent")
expect_identical(nrow(result$core), 3L)
})
})
# cerebellar region ops (vertices + meshes) ----
make_cerebellar_atlas <- function() {
sf_geom <- sf::st_sf(
label = c("lobule_I", "dentate"),
view = c("flatmap", "nuclei"),
geometry = sf::st_sfc(
make_polygon(),
sf::st_polygon(list(matrix(
c(2, 2, 4, 2, 4, 4, 2, 2),
ncol = 2,
byrow = TRUE
)))
)
)
core <- data.frame(
hemi = c(NA, NA),
region = c("lobule I", "dentate"),
label = c("lobule_I", "dentate")
)
vertices <- data.frame(label = "lobule_I")
vertices$vertices <- list(1L:3L)
meshes <- data.frame(label = "dentate")
meshes$mesh <- list(list(
vertices = data.frame(x = 1:4, y = 1:4, z = 1:4),
faces = data.frame(i = 1L, j = 2L, k = 3L)
))
ggseg_atlas(
atlas = "cb",
type = "cerebellar",
core = core,
data = ggseg_data_cerebellar(
geom = sf_geom,
vertices = vertices,
meshes = meshes
)
)
}
describe("cerebellar region ops preserve vertices + meshes", {
it("atlas_region_remove keeps deep-nuclei meshes and cerebellar type", {
cb <- make_cerebellar_atlas()
result <- atlas_region_remove(cb, "nonexistent")
expect_identical(atlas_type(result), "cerebellar")
expect_s3_class(result$data, "ggseg_data_cerebellar")
expect_true("dentate" %in% result$data$meshes$label)
expect_true("lobule_I" %in% result$data$vertices$label)
})
it("atlas_region_remove drops a removed structure from both 3D payloads", {
cb <- make_cerebellar_atlas()
result <- atlas_region_remove(cb, "dentate", match_on = "label")
expect_identical(atlas_type(result), "cerebellar")
expect_false("dentate" %in% result$data$meshes$label)
expect_true("lobule_I" %in% result$data$vertices$label)
})
it("atlas_region_keep keeps cerebellar type and the kept structure", {
cb <- make_cerebellar_atlas()
result <- atlas_region_keep(cb, "dentate", match_on = "label")
expect_identical(atlas_type(result), "cerebellar")
expect_true("dentate" %in% result$data$meshes$label)
expect_false("lobule_I" %in% result$data$vertices$label)
})
})
# atlas_region_contextual ----
describe("atlas_region_contextual", {
it("removes from core and palette but keeps sf geometry", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "parietal")
expect_false("lh_parietal" %in% result$core$label)
expect_false("lh_parietal" %in% names(result$palette))
expect_true("lh_parietal" %in% result$data$geom$label)
})
it("removes from 3D data", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "parietal")
expect_false("lh_parietal" %in% result$data$vertices$label)
})
it("matches on label when specified", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "^lh_f", match_on = "label")
expect_identical(nrow(result$core), 2L)
expect_identical(result$core$label, c("lh_parietal", "rh_frontal"))
})
it("draws contextual sf rows before remaining core rows", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "parietal")
sf <- result$data$geom
is_core <- sf$label %in% result$core$label
# the demoted region (lh_parietal) was in the middle; it must now lead
expect_identical(sf$label[1], "lh_parietal")
expect_lt(max(which(!is_core)), min(which(is_core)))
})
it("matches case-insensitively by default", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "FRONTAL")
expect_false(any(grepl("frontal", result$core$region, fixed = TRUE)))
})
it("respects ignore.case = FALSE", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "FRONTAL", ignore.case = FALSE)
# no region matches the upper-case pattern, so nothing is demoted
expect_identical(nrow(result$core), nrow(atlas$core))
})
it("retains every geometry row after demoting a region", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "parietal")
# demoting only moves rows behind core; no geometry is dropped or added
expect_setequal(result$data$geom$label, atlas$data$geom$label)
expect_identical(nrow(result$data$geom), nrow(atlas$data$geom))
# the demoted region keeps its geometry
expect_true("lh_parietal" %in% result$data$geom$label)
})
it("operates on a polygon-only atlas without sf", {
poly <- as_polygon_atlas(make_test_atlas())
expect_null(poly$data$sf)
result <- atlas_region_contextual(poly, "parietal")
expect_null(result$data$sf)
expect_s3_class(result$data$geom, "brain_polygons")
# demoted geometry retained, dropped from core, drawn first (behind core)
expect_true("lh_parietal" %in% result$data$geom$label)
expect_false("lh_parietal" %in% result$core$label)
is_core <- result$data$geom$label %in% result$core$label
expect_lt(max(which(!is_core)), min(which(is_core)))
})
})
# atlas_region_op ----
describe("atlas_region_op", {
make_op_atlas <- function() {
outer <- sf::st_polygon(list(matrix(
c(0, 0, 10, 0, 10, 10, 0, 10, 0, 0),
ncol = 2,
byrow = TRUE
)))
inner <- sf::st_polygon(list(matrix(
c(3, 3, 7, 3, 7, 7, 3, 7, 3, 3),
ncol = 2,
byrow = TRUE
)))
sf_geom <- sf::st_sf(
label = c("cortex", "wm"),
view = c("v1", "v1"),
geometry = sf::st_sfc(outer, inner)
)
core <- data.frame(
hemi = c(NA, NA),
region = c("cortex", "wm"),
label = c("cortex", "wm")
)
ggseg_atlas(
atlas = "op",
type = "subcortical",
palette = c(cortex = "#aaaaaa", wm = "#bbbbbb"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
}
area_of <- function(atlas, lbl) {
g <- atlas$data$geom$geometry[atlas$data$geom$label == lbl]
as.numeric(sum(sf::st_area(g)))
}
holes_of <- function(atlas, lbl) {
g <- atlas$data$geom$geometry[[which(atlas$data$geom$label == lbl)[1]]]
if (inherits(g, "MULTIPOLYGON")) {
sum(vapply(g, length, integer(1))) - length(g)
} else if (inherits(g, "POLYGON")) {
length(g) - 1
} else {
NA_integer_
}
}
it("difference punches y out of x as a hole", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
expect_identical(holes_of(r, "ribbon"), 1)
expect_identical(area_of(r, "ribbon"), 100 - 16)
})
it("intersection keeps only the overlap", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "intersection",
into = "ov"
)
expect_identical(area_of(r, "ov"), 16)
})
it("union merges both operands", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "union",
into = "both"
)
expect_identical(area_of(r, "both"), 100)
})
it("leaves the input regions in place", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
expect_true(all(c("cortex", "wm") %in% r$data$geom$label))
})
it("result is contextual without a colour", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
expect_false("ribbon" %in% r$core$label)
expect_false("ribbon" %in% names(r$palette))
expect_true("ribbon" %in% r$data$geom$label)
})
it("colour registers the result in core and palette", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon",
colour = "#123456"
)
expect_true("ribbon" %in% r$core$label)
expect_identical(r$palette[["ribbon"]], "#123456")
})
it("draws a contextual result behind core regions", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
sf <- r$data$geom
is_core <- sf$label %in% r$core$label
expect_lt(max(which(!is_core)), min(which(is_core)))
})
it("writes the result into the polygons slot too", {
r <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
# the result region is added alongside the untouched operands
expect_setequal(r$data$geom$label, c("cortex", "wm", "ribbon"))
})
it("operates on a polygon-only atlas and stays polygon-only", {
poly <- as_polygon_atlas(make_op_atlas())
expect_null(poly$data$sf)
r <- atlas_region_op(
poly,
"cortex",
"wm",
action = "difference",
into = "ribbon"
)
expect_null(r$data$sf)
expect_true("ribbon" %in% r$data$geom$label)
rehydrated <- as_sf_atlas(r)
g <- rehydrated$data$geom$geometry[rehydrated$data$geom$label == "ribbon"]
expect_identical(as.numeric(sum(sf::st_area(g))), 100 - 16)
})
it("matches sf-backed and polygon-only results", {
sf_res <- atlas_region_op(
make_op_atlas(),
"cortex",
"wm",
action = "intersection",
into = "ov"
)
poly_res <- atlas_region_op(
as_polygon_atlas(make_op_atlas()),
"cortex",
"wm",
action = "intersection",
into = "ov"
)
poly_sf <- as_sf_atlas(poly_res)$data$geom
sf_area <- as.numeric(sum(sf::st_area(
sf_res$data$geom$geometry[sf_res$data$geom$label == "ov"]
)))
poly_area <- as.numeric(sum(sf::st_area(
poly_sf$geometry[poly_sf$label == "ov"]
)))
expect_identical(sf_area, poly_area)
})
})
# atlas_region_rename ----
describe("atlas_region_rename", {
it("renames matching regions with string replacement", {
atlas <- make_test_atlas()
result <- atlas_region_rename(atlas, "frontal", "prefrontal")
non_parietal <- result$core$region != "parietal"
expect_true(all(result$core$region[non_parietal] == "prefrontal"))
})
it("renames matching regions with function", {
atlas <- make_test_atlas()
result <- atlas_region_rename(atlas, ".*", toupper)
expect_true(all(result$core$region %in% c("FRONTAL", "PARIETAL")))
})
it("does not modify labels", {
atlas <- make_test_atlas()
result <- atlas_region_rename(atlas, "frontal", "prefrontal")
expect_identical(result$core$label, atlas$core$label)
})
it("preserves NA regions", {
atlas <- make_test_atlas()
atlas$core$region[1] <- NA
result <- atlas_region_rename(atlas, "parietal", "PARIETAL")
expect_true(is.na(result$core$region[1]))
})
})
# atlas_region_keep ----
describe("atlas_region_keep", {
it("keeps only matching regions in core and palette", {
atlas <- make_test_atlas()
result <- atlas_region_keep(atlas, "frontal")
expect_identical(nrow(result$core), 2L)
expect_true(all(result$core$region == "frontal"))
expect_length(result$palette, 2)
})
it("preserves sf geometry for surface continuity", {
atlas <- make_test_atlas()
result <- atlas_region_keep(atlas, "frontal")
expect_identical(nrow(result$data$geom), nrow(atlas$data$geom))
})
it("filters 3D data", {
atlas <- make_test_atlas()
result <- atlas_region_keep(atlas, "frontal")
expect_identical(nrow(result$data$vertices), 2L)
})
it("matches on label", {
atlas <- make_test_atlas()
result <- atlas_region_keep(atlas, "^lh_", match_on = "label")
expect_identical(nrow(result$core), 2L)
})
})
# atlas_core_add ----
describe("atlas_core_add", {
it("joins metadata columns to core", {
atlas <- make_test_atlas()
meta <- data.frame(
region = c("frontal", "parietal"),
lobe = c("frontal", "parietal")
)
result <- atlas_core_add(atlas, meta)
expect_true("lobe" %in% names(result$core))
expect_identical(result$core$lobe, c("frontal", "parietal", "frontal"))
})
it("joins by custom column", {
atlas <- make_test_atlas()
meta <- data.frame(
label = "lh_frontal",
network = "DMN"
)
result <- atlas_core_add(atlas, meta, by = "label")
expect_true("network" %in% names(result$core))
expect_identical(result$core$network[1], "DMN")
expect_true(is.na(result$core$network[2]))
})
it("never adds rows to core", {
atlas <- make_test_atlas()
meta <- data.frame(
region = c("frontal", "parietal"),
lobe = c("frontal", "parietal")
)
result <- atlas_core_add(atlas, meta)
expect_identical(nrow(result$core), nrow(atlas$core))
})
it("errors when data has duplicate join keys", {
atlas <- make_test_atlas()
meta <- data.frame(
region = c("frontal", "frontal"),
lobe = c("a", "b")
)
expect_error(atlas_core_add(atlas, meta), "unique")
})
})
# atlas_view_remove ----
describe("atlas_view_remove", {
it("removes matching views from sf", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove(atlas, "axial_1")
expect_false("axial_1" %in% result$data$geom$view)
expect_true("axial_2" %in% result$data$geom$view)
})
it("removes multiple views with vector", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove(atlas, c("axial_1", "axial_2"))
expect_identical(unique(result$data$geom$view), "sagittal")
})
it("warns when no 2D data", {
atlas <- make_test_atlas()
atlas$data$geom <- NULL
expect_warning(atlas_view_remove(atlas, "lateral"), "no 2D geometry")
})
it("removes views from a polygon-only atlas without sf", {
atlas <- make_test_atlas()
atlas$data$sf <- NULL
result <- atlas_view_remove(atlas, "medial")
expect_null(result$data$sf)
expect_false("medial" %in% atlas_views(result))
expect_true("lateral" %in% atlas_views(result))
})
it("warns when all views removed", {
atlas <- make_multiview_atlas()
expect_warning(
expect_warning(atlas_view_remove(atlas, ".*"), "All views removed"),
"no 2D geometry"
)
})
})
# atlas_view_keep ----
describe("atlas_view_keep", {
it("keeps only matching views", {
atlas <- make_multiview_atlas()
result <- atlas_view_keep(atlas, "sagittal")
expect_identical(unique(result$data$geom$view), "sagittal")
})
it("keeps multiple views with vector", {
atlas <- make_multiview_atlas()
result <- atlas_view_keep(atlas, c("axial_1", "sagittal"))
expect_identical(
sort(unique(result$data$geom$view)),
c("axial_1", "sagittal")
)
})
it("warns when no views match", {
atlas <- make_multiview_atlas()
expect_warning(atlas_view_keep(atlas, "nonexistent"), "No views matched")
})
})
# atlas_view_remove_region ----
describe("atlas_view_remove_region", {
it("removes region from sf only, keeps core and palette", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove_region(atlas, "lh_frontal")
expect_false("lh_frontal" %in% result$data$geom$label)
expect_true("lh_frontal" %in% result$core$label)
expect_true("lh_frontal" %in% names(result$palette))
})
it("matches on region via core lookup", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove_region(atlas, "frontal", match_on = "region")
expect_false("lh_frontal" %in% result$data$geom$label)
expect_false("rh_frontal" %in% result$data$geom$label)
expect_true("lh_parietal" %in% result$data$geom$label)
})
it("preserves NA-label rows", {
atlas <- make_multiview_atlas()
atlas$data$geom$label[1] <- NA
n_na <- sum(is.na(atlas$data$geom$label))
result <- atlas_view_remove_region(atlas, "insula")
expect_identical(sum(is.na(result$data$geom$label)), n_na)
})
it("preserves context geometry labels", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove_region(atlas, "ctx_left")
expect_false("ctx_left" %in% result$data$geom$label)
})
})
# atlas_view_remove_small ----
describe("atlas_view_remove_small", {
it("removes small polygons below threshold", {
atlas <- make_multiview_atlas()
n_before <- nrow(atlas$data$geom)
expect_message(
result <- atlas_view_remove_small(atlas, min_area = 2),
"Removed"
)
n_after <- nrow(result$data$geom)
expect_lt(n_after, n_before)
})
it("never removes context geometries", {
atlas <- make_multiview_atlas()
ctx_labels <- setdiff(atlas$data$geom$label, c(atlas$core$label, NA))
expect_message(
result <- atlas_view_remove_small(atlas, min_area = 2),
"Removed"
)
remaining_labels <- unique(result$data$geom$label)
expect_true(all(ctx_labels %in% remaining_labels))
})
it("scopes to specific views", {
atlas <- make_multiview_atlas()
expect_message(
result_all <- atlas_view_remove_small(atlas, min_area = 2),
"Removed"
)
expect_message(
result_axial <- atlas_view_remove_small(
atlas,
min_area = 2,
views = "axial"
),
"Removed"
)
expect_gte(nrow(result_axial$data$geom), nrow(result_all$data$geom))
})
it("preserves core and palette", {
atlas <- make_multiview_atlas()
expect_message(
result <- atlas_view_remove_small(atlas, min_area = 2),
"Removed"
)
expect_identical(result$core, atlas$core)
expect_identical(result$palette, atlas$palette)
})
it("warns when no 2D data", {
atlas <- make_test_atlas()
atlas$data$geom <- NULL
expect_warning(
atlas_view_remove_small(atlas, min_area = 1),
"no 2D geometry"
)
})
it("removes small geometries from a polygon-only atlas", {
atlas <- make_multiview_atlas()
poly <- as_polygon_atlas(atlas)
expect_message(
result <- atlas_view_remove_small(poly, min_area = 2),
"Removed"
)
expect_null(result$data$sf)
n_geoms <- function(p) {
flat <- polygons_unnest(p)
length(unique(paste(flat$label, flat$view)))
}
expect_lt(n_geoms(result$data$geom), nrow(atlas$data$geom))
})
})
# atlas_view_gather ----
describe("atlas_view_gather", {
it("repositions views without gaps", {
atlas <- make_multiview_atlas()
trimmed <- atlas_view_remove(atlas, "axial_2")
result <- atlas_view_gather(trimmed)
expect_s3_class(result$data$geom, "sf")
expect_identical(
sort(unique(result$data$geom$view)),
sort(unique(trimmed$data$geom$view))
)
})
it("warns when no 2D data", {
atlas <- make_test_atlas()
atlas$data$geom <- NULL
expect_warning(atlas_view_gather(atlas), "no 2D geometry")
})
it("repositions a polygon-only atlas without sf", {
atlas <- make_multiview_atlas()
poly <- as_polygon_atlas(atlas)
result <- atlas_view_gather(poly)
expect_null(result$data$sf)
expect_s3_class(result$data$geom, "brain_polygons")
# each hemi+view group occupies a disjoint horizontal band (packed left
# to right with gaps); the exact ordering is representation-dependent.
flat <- polygons_unnest(result$data$geom)
hemi <- rep("", nrow(flat))
hemi[grepl("^lh", flat$label)] <- "left"
hemi[grepl("^rh", flat$label)] <- "right"
groups <- split(seq_len(nrow(flat)), paste(hemi, flat$view))
ranges <- lapply(groups, function(idx) range(flat$x[idx]))
ordered <- ranges[order(vapply(ranges, `[`, numeric(1), 1))]
for (i in seq_len(length(ordered) - 1)) {
expect_lte(ordered[[i]][2], ordered[[i + 1]][1])
}
})
it("keeps cortical hemi+view groups spatially coherent", {
atlas <- make_cortical_hemi_atlas()
result <- atlas_view_gather(atlas)
sf <- result$data$geom
for (v in unique(sf$view)) {
lh_rows <- sf[sf$view == v & grepl("^lh_", sf$label), ]
rh_rows <- sf[sf$view == v & grepl("^rh_", sf$label), ]
if (nrow(lh_rows) > 0 && nrow(rh_rows) > 0) {
lh_bbox <- sf::st_bbox(lh_rows)
rh_bbox <- sf::st_bbox(rh_rows)
expect_true(
lh_bbox["xmax"] < rh_bbox["xmin"] ||
rh_bbox["xmax"] < lh_bbox["xmin"]
)
}
}
})
})
# atlas_view_reorder ----
describe("atlas_view_reorder", {
it("reorders views as specified", {
atlas <- make_multiview_atlas()
result <- atlas_view_reorder(atlas, c("sagittal", "axial_2", "axial_1"))
views_in_order <- unique(result$data$geom$view)
expect_identical(views_in_order, c("sagittal", "axial_2", "axial_1"))
})
it("appends unspecified views at end", {
atlas <- make_multiview_atlas()
result <- atlas_view_reorder(atlas, "sagittal")
views_in_order <- unique(result$data$geom$view)
expect_identical(views_in_order[1], "sagittal")
expect_length(views_in_order, 3)
})
it("appends all current views when given only nonexistent ones", {
atlas <- make_multiview_atlas()
result <- atlas_view_reorder(atlas, "nonexistent")
expect_length(unique(result$data$geom$view), 3)
})
it("reorders cortical views with hemi sub-groups", {
atlas <- make_cortical_hemi_atlas()
result <- atlas_view_reorder(atlas, c("medial", "lateral"))
views_in_order <- unique(result$data$geom$view)
expect_identical(views_in_order, c("medial", "lateral"))
sf <- result$data$geom
medial_bbox <- sf::st_bbox(sf[sf$view == "medial", ])
lateral_bbox <- sf::st_bbox(sf[sf$view == "lateral", ])
expect_lt(medial_bbox["xmax"], lateral_bbox["xmin"])
})
})
# polygon-only view operations ----
describe("view operations on polygon-only atlases", {
poly_views <- function(atlas) {
unique(polygons_unnest(atlas$data$geom)$view)
}
it("atlas_context_remove drops context geometry without sf", {
poly <- as_polygon_atlas(make_test_atlas())
result <- atlas_context_remove(poly)
expect_null(result$data$sf)
expect_false("lh_unknown" %in% result$data$geom$label)
expect_setequal(result$data$geom$label, result$core$label)
})
it("atlas_view_keep keeps only matching views without sf", {
poly <- as_polygon_atlas(make_multiview_atlas())
result <- atlas_view_keep(poly, "axial_1")
expect_null(result$data$sf)
expect_identical(poly_views(result), "axial_1")
})
it("atlas_view_remove_region drops a region's geometry without sf", {
poly <- as_polygon_atlas(make_test_atlas())
result <- atlas_view_remove_region(poly, "lh_frontal", match_on = "label")
expect_null(result$data$sf)
expect_false("lh_frontal" %in% result$data$geom$label)
# core is untouched by a view-only removal
expect_true("lh_frontal" %in% result$core$label)
})
it("atlas_view_remove_region by region matches sf-path geometry", {
atlas <- make_multiview_atlas()
sf_res <- atlas_view_remove_region(atlas, "frontal", match_on = "region")
poly_res <- atlas_view_remove_region(
as_polygon_atlas(atlas),
"frontal",
match_on = "region"
)
expect_setequal(
unique(sf_res$data$geom$label),
poly_res$data$geom$label
)
})
it("atlas_view_reorder lays views out in the requested order", {
poly <- as_polygon_atlas(make_cortical_hemi_atlas())
result <- atlas_view_reorder(poly, c("medial", "lateral"))
expect_null(result$data$sf)
flat <- polygons_unnest(result$data$geom)
medial_xmax <- max(flat$x[flat$view == "medial"])
lateral_xmin <- min(flat$x[flat$view == "lateral"])
expect_lte(medial_xmax, lateral_xmin)
})
})
# context ordering in as.data.frame ----
describe("as.data.frame context ordering", {
it("places context geometries before non-context", {
atlas <- make_test_atlas()
df <- as.data.frame(atlas)
is_ctx <- !df$label %in% atlas$core$label | is.na(df$label)
ctx_positions <- which(is_ctx)
non_ctx_positions <- which(!is_ctx)
if (length(ctx_positions) > 0 && length(non_ctx_positions) > 0) {
expect_lt(max(ctx_positions), min(non_ctx_positions))
}
})
it("works with atlas that has no context geometry", {
atlas <- make_test_atlas()
keep <- atlas$data$geom$label %in% atlas$core$label
atlas$data$geom <- atlas$data$geom[keep, ]
df <- as.data.frame(atlas)
expect_s3_class(df, "sf")
expect_identical(nrow(df), 3L)
})
})
describe("subclass preservation", {
it("manipulation functions preserve cortical_atlas subclass", {
atlas <- make_test_atlas()
expect_s3_class(atlas, "cortical_atlas")
expect_s3_class(
atlas_region_remove(atlas, "parietal"),
"cortical_atlas"
)
expect_s3_class(
atlas_region_keep(atlas, "frontal"),
"cortical_atlas"
)
expect_s3_class(
atlas_region_contextual(atlas, "parietal"),
"cortical_atlas"
)
expect_s3_class(
atlas_region_rename(atlas, "frontal", "front"),
"cortical_atlas"
)
expect_s3_class(
atlas_core_add(atlas, data.frame(region = "frontal", x = 1)),
"cortical_atlas"
)
})
it("view functions preserve cortical_atlas subclass", {
atlas <- make_multiview_atlas()
expect_s3_class(atlas, "cortical_atlas")
expect_s3_class(
atlas_view_remove(atlas, "sagittal"),
"cortical_atlas"
)
expect_s3_class(
atlas_view_keep(atlas, "axial"),
"cortical_atlas"
)
expect_s3_class(
atlas_view_remove_region(atlas, "lh_frontal"),
"cortical_atlas"
)
expect_message(
removed <- atlas_view_remove_small(atlas, min_area = 2),
"Removed"
)
expect_s3_class(removed, "cortical_atlas")
expect_s3_class(atlas_view_gather(atlas), "cortical_atlas")
expect_s3_class(
atlas_view_reorder(atlas, c("sagittal", "axial_1", "coronal_2")),
"cortical_atlas"
)
})
it("bundled atlases have correct subclasses", {
expect_s3_class(
dk(),
c("cortical_atlas", "ggseg_atlas", "list"),
exact = TRUE
)
expect_s3_class(
aseg(),
c("subcortical_atlas", "ggseg_atlas", "list"),
exact = TRUE
)
expect_s3_class(
tracula(),
c("tract_atlas", "ggseg_atlas", "list"),
exact = TRUE
)
})
})
describe("deprecated wrappers", {
it("brain_regions() warns and returns regions", {
lifecycle::expect_deprecated(
result <- brain_regions(dk())
)
expect_type(result, "character")
expect_gt(length(result), 0)
})
it("brain_labels() warns and returns labels", {
lifecycle::expect_deprecated(
result <- brain_labels(dk())
)
expect_type(result, "character")
expect_gt(length(result), 0)
})
it("brain_views() warns and returns views", {
lifecycle::expect_deprecated(
result <- brain_views(dk())
)
expect_type(result, "character")
})
})
describe("atlas_region_remove", {
it("removes region from cortical atlas with vertices", {
atlas <- make_test_atlas()
result <- atlas_region_remove(atlas, "frontal")
expect_false("frontal" %in% atlas_regions(result))
expect_true("parietal" %in% atlas_regions(result))
})
it("removes region by label pattern", {
atlas <- make_test_atlas()
result <- atlas_region_remove(atlas, "lh_frontal", match_on = "label")
labels <- atlas_labels(result)
expect_false("lh_frontal" %in% labels)
expect_true("rh_frontal" %in% labels)
})
})
describe("atlas_region_contextual", {
it("removes from core but keeps sf geometry", {
atlas <- make_test_atlas()
result <- atlas_region_contextual(atlas, "parietal")
expect_false("parietal" %in% atlas_regions(result))
sf_labels <- atlas_sf(result)$label
expect_true("lh_parietal" %in% sf_labels)
})
})
describe("atlas_view_remove_region", {
it("removes region geometry from specific views", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove_region(
atlas,
"frontal",
match_on = "region",
views = "axial_1"
)
sf_data <- atlas_sf(result)
axial1 <- sf_data[sf_data$view == "axial_1", ]
expect_false(any(grepl("frontal", axial1$region, ignore.case = TRUE)))
})
it("removes by label pattern", {
atlas <- make_multiview_atlas()
result <- atlas_view_remove_region(atlas, "lh_frontal", match_on = "label")
sf_data <- atlas_sf(result)
expect_false("lh_frontal" %in% sf_data$label)
})
it("warns when atlas has no 2D data", {
core <- data.frame(hemi = "left", region = "frontal", label = "lh_frontal")
vertices <- data.frame(label = "lh_frontal")
vertices$vertices <- list(1L:3L)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
expect_warning(
atlas_view_remove_region(atlas, "frontal"),
"no 2D geometry"
)
})
})
describe("atlas_view_keep", {
it("keeps only specified views", {
atlas <- make_multiview_atlas()
result <- atlas_view_keep(atlas, "axial_1")
views <- atlas_views(result)
expect_identical(views, "axial_1")
})
it("warns when no views match", {
atlas <- make_multiview_atlas()
expect_warning(
result <- atlas_view_keep(atlas, "nonexistent"),
"No views matched"
)
})
it("warns when atlas has no 2D data", {
core <- data.frame(hemi = "left", region = "frontal", label = "lh_frontal")
vertices <- data.frame(label = "lh_frontal")
vertices$vertices <- list(1L:3L)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
expect_warning(atlas_view_keep(atlas, "lateral"), "no 2D geometry")
})
})
describe("atlas_view_reorder", {
it("warns when atlas has no 2D data", {
core <- data.frame(hemi = "left", region = "frontal", label = "lh_frontal")
vertices <- data.frame(label = "lh_frontal")
vertices$vertices <- list(1L:3L)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
expect_warning(atlas_view_reorder(atlas, "lateral"), "no 2D geometry")
})
it("appends unmentioned views to end of order", {
atlas <- make_multiview_atlas()
result <- atlas_view_reorder(atlas, "sagittal")
views <- atlas_views(result)
expect_identical(views[1], "sagittal")
})
it("warns when sf has no rows (empty views)", {
atlas <- make_multiview_atlas()
atlas$data$geom <- atlas$data$geom[0, ]
expect_warning(
atlas_view_reorder(atlas, "lateral"),
"No matching views"
)
})
})
describe("rebuild_atlas_data", {
it("works with subcortical atlas sf", {
result <- atlas_view_keep(aseg(), "axial")
expect_s3_class(result, "ggseg_atlas")
expect_s3_class(result$data, "ggseg_data_subcortical")
})
it("works with tract atlas sf", {
result <- atlas_view_keep(tracula(), "sagittal")
expect_s3_class(result, "ggseg_atlas")
expect_s3_class(result$data, "ggseg_data_tract")
})
})
describe("atlas_region_remove with subcortical atlas", {
it("removes matching regions from subcortical core, palette, and meshes", {
result <- atlas_region_remove(aseg(), "Thalamus")
expect_false(any(grepl("Thalamus", result$core$region, ignore.case = TRUE)))
expect_false(any(grepl(
"Thalamus",
names(result$palette),
ignore.case = TRUE
)))
expect_false(any(grepl(
"Thalamus",
result$data$meshes$label,
ignore.case = TRUE
)))
})
})
describe("atlas_region_contextual with subcortical atlas", {
it("removes region from core/palette but keeps sf geometry", {
result <- atlas_region_contextual(aseg(), "Thalamus")
expect_false(any(grepl(
"Thalamus",
result$core$region,
ignore.case = TRUE
)))
expect_false(any(grepl(
"Thalamus",
names(result$palette),
ignore.case = TRUE
)))
expect_s3_class(result$data, "ggseg_data_subcortical")
})
})
describe("atlas_region_keep with subcortical atlas", {
it("keeps only matching regions", {
result <- atlas_region_keep(aseg(), "hippocampus")
expect_true(all(grepl(
"hippocampus",
result$core$region,
ignore.case = TRUE
)))
expect_s3_class(result$data, "ggseg_data_subcortical")
})
})
describe("atlas_view_remove_region matching by region", {
it("removes region geometry via region column match", {
atlas <- make_test_atlas()
result <- atlas_view_remove_region(atlas, "frontal", match_on = "region")
remaining_labels <- result$data$geom$label
expect_false("lh_frontal" %in% remaining_labels)
expect_false("rh_frontal" %in% remaining_labels)
expect_true("lh_parietal" %in% remaining_labels)
})
it("warns and returns NULL sf when all geometries removed", {
atlas <- make_test_atlas()
expect_warning(
expect_warning(
atlas_view_remove_region(atlas, ".*", match_on = "label"),
"All region geometries removed"
),
"no 2D geometry"
)
})
})
describe("atlas_view_reorder with nonexistent views", {
it("appends unmatched order entries but still reorders", {
atlas <- make_test_atlas()
result <- atlas_view_reorder(atlas, "nonexistent")
expect_s3_class(result, "ggseg_atlas")
})
})
describe("atlas_region_remove with tract atlas", {
it("removes matching regions from tract core and palette", {
result <- atlas_region_remove(tracula(), "corticospinal")
expect_false(any(grepl(
"corticospinal",
result$core$region,
ignore.case = TRUE
)))
expect_s3_class(result$data, "ggseg_data_tract")
})
it("removes sf labels matching the pattern directly", {
result <- atlas_region_remove(tracula(), "cst")
remaining_sf <- result$data$geom$label
expect_false(any(grepl(
"cst",
remaining_sf,
ignore.case = TRUE
)))
})
})
describe("atlas_region_contextual with tract atlas", {
it("keeps sf but removes from core/palette", {
result <- atlas_region_contextual(tracula(), "corticospinal")
expect_false(any(grepl(
"corticospinal",
result$core$region,
ignore.case = TRUE
)))
expect_s3_class(result$data, "ggseg_data_tract")
})
})
describe("atlas_region_keep with tract atlas", {
it("keeps only matching regions", {
result <- atlas_region_keep(tracula(), "corticospinal")
expect_true(all(grepl(
"corticospinal",
result$core$region,
ignore.case = TRUE
)))
expect_s3_class(result$data, "ggseg_data_tract")
})
})
describe("guess_type edge cases", {
it("returns subcortical when view column has no medial/lateral", {
x <- data.frame(view = c("axial", "coronal"))
expect_warning(
result <- guess_type(x),
"Atlas type not set"
)
expect_identical(result, "subcortical")
})
it("returns subcortical when no view info at all", {
x <- data.frame(a = 1)
expect_warning(
result <- guess_type(x),
"Atlas type not set"
)
expect_identical(result, "subcortical")
})
it("reads views from the modern $data$geom slot for a ggseg_atlas", {
sf_geom <- sf::st_sf(
label = "lh_frontal",
view = "lateral",
geometry = sf::st_sfc(make_polygon())
)
core <- data.frame(
hemi = "left",
region = "frontal",
label = "lh_frontal"
)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(geom = sf_geom)
)
# no legacy $sf slot: the view must be read from $data$geom
atlas$type <- NULL
expect_warning(
result <- guess_type(atlas),
"Atlas type not set"
)
expect_identical(result, "cortical")
})
it("falls back to the legacy bare $sf slot when $data is not unified", {
legacy <- structure(
list(
atlas = "old",
sf = sf::st_sf(
label = "lh_frontal",
view = "lateral",
geometry = sf::st_sfc(make_polygon())
)
),
class = "brain_atlas"
)
expect_warning(
result <- guess_type(legacy),
"Atlas type not set"
)
expect_identical(result, "cortical")
})
})
describe("brain_atlas S3 method dispatch", {
it("atlas_regions works on brain_atlas class", {
atlas <- dk()
class(atlas) <- c("brain_atlas", "list")
result <- atlas_regions(atlas)
expect_type(result, "character")
expect_gt(length(result), 0)
})
it("atlas_labels works on brain_atlas class", {
atlas <- dk()
class(atlas) <- c("brain_atlas", "list")
result <- atlas_labels(atlas)
expect_type(result, "character")
expect_gt(length(result), 0)
})
it("atlas_type works on brain_atlas class", {
atlas <- dk()
class(atlas) <- c("brain_atlas", "list")
result <- atlas_type(atlas)
expect_identical(result, "cortical")
})
})
describe("atlas_region_remove with no sf data", {
it("returns NULL sf when atlas has no sf", {
core <- data.frame(
hemi = c("left", "right"),
region = c("frontal", "parietal"),
label = c("lh_frontal", "rh_parietal")
)
vertices <- data.frame(
label = c("lh_frontal", "rh_parietal")
)
vertices$vertices <- list(1L:3L, 4L:6L)
atlas <- ggseg_atlas(
atlas = "test",
type = "cortical",
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
result <- atlas_region_remove(atlas, "frontal")
expect_null(result$data$sf)
expect_identical(nrow(result$core), 1L)
})
})
# coverage backfill for atlas_utils.R ----
describe("atlas_region_op edge cases", {
make_sq <- function(x, y, s = 2) {
sf::st_polygon(list(matrix(
c(x, y, x + s, y, x + s, y + s, x, y + s, x, y),
ncol = 2,
byrow = TRUE
)))
}
make_simple_op_atlas <- function() {
sf_geom <- sf::st_sf(
label = c("cortex", "wm"),
view = c("v1", "v1"),
geometry = sf::st_sfc(make_sq(0, 0, 10), make_sq(3, 3, 4))
)
core <- data.frame(
hemi = c(NA, NA),
region = c("cortex", "wm"),
label = c("cortex", "wm")
)
ggseg_atlas(
atlas = "op",
type = "subcortical",
palette = c(cortex = "#aaaaaa", wm = "#bbbbbb"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
}
it("errors when into is not a single label", {
expect_error(
atlas_region_op(
make_simple_op_atlas(),
"cortex",
"wm",
action = "union",
into = c("a", "b")
),
"must be a single label",
fixed = TRUE
)
})
it("errors when the op produces no geometry", {
expect_error(
atlas_region_op(
make_simple_op_atlas(),
"cortex",
"cortex",
action = "difference",
into = "empty"
),
"produced no geometry",
fixed = TRUE
)
})
it("computes a symmetric difference", {
r <- atlas_region_op(
make_simple_op_atlas(),
"cortex",
"wm",
action = "symdifference",
into = "sd"
)
expect_true("sd" %in% r$data$geom$label)
})
it("matches operands on the region column", {
r <- atlas_region_op(
make_simple_op_atlas(),
"cortex",
"wm",
action = "union",
into = "u",
match_on = "region"
)
expect_true("u" %in% r$data$geom$label)
})
it("errors when an atlas has no 2D geometry to operate on", {
atlas <- make_simple_op_atlas()
atlas$data$geom <- NULL
expect_error(
atlas_region_op(atlas, "cortex", "wm", action = "union", into = "u"),
"no 2D geometry",
fixed = TRUE
)
})
it("skips views with no x geometry but keeps views with both", {
sf_geom <- sf::st_sf(
label = c("a", "b", "b"),
view = c("v1", "v1", "v2"),
geometry = sf::st_sfc(make_sq(0, 0), make_sq(1, 1), make_sq(0, 0))
)
core <- data.frame(
hemi = c(NA, NA),
region = c("a", "b"),
label = c("a", "b")
)
atlas <- ggseg_atlas(
atlas = "op",
type = "subcortical",
palette = c(a = "#aaaaaa", b = "#bbbbbb"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
r <- atlas_region_op(atlas, "a", "b", action = "union", into = "u")
expect_identical(unique(r$data$geom$view[r$data$geom$label == "u"]), "v1")
})
it("intersects per view, dropping views with only x", {
sf_geom <- sf::st_sf(
label = c("a", "b", "a"),
view = c("v1", "v1", "v2"),
geometry = sf::st_sfc(make_sq(0, 0), make_sq(1, 1), make_sq(0, 0))
)
core <- data.frame(
hemi = c(NA, NA),
region = c("a", "b"),
label = c("a", "b")
)
atlas <- ggseg_atlas(
atlas = "op",
type = "subcortical",
palette = c(a = "#aaaaaa", b = "#bbbbbb"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
r <- atlas_region_op(atlas, "a", "b", action = "intersection", into = "ix")
expect_identical(unique(r$data$geom$view[r$data$geom$label == "ix"]), "v1")
})
})
describe("atlas_context_remove edge cases", {
make_sq <- function(x, y, s = 2) {
sf::st_polygon(list(matrix(
c(x, y, x + s, y, x + s, y + s, x, y + s, x, y),
ncol = 2,
byrow = TRUE
)))
}
it("returns the atlas unchanged when there is no 2D geometry", {
core <- data.frame(hemi = NA, region = "a", label = "a")
vertices <- data.frame(label = "a")
vertices$vertices <- list(1L:3L)
atlas <- ggseg_atlas(
atlas = "t",
type = "cortical",
palette = c(a = "#aaaaaa"),
core = core,
data = ggseg_data_cortical(vertices = vertices)
)
expect_identical(atlas_context_remove(atlas), atlas)
})
it("drops contextual sf rows whose label is not in core", {
sf_geom <- sf::st_sf(
label = c("a", "b", "ctx"),
view = c("v1", "v1", "v1"),
geometry = sf::st_sfc(make_sq(0, 0), make_sq(3, 3), make_sq(6, 6))
)
core <- data.frame(
hemi = c(NA, NA, NA),
region = c("a", "b", "c"),
label = c("a", "b", "ctx")
)
atlas <- ggseg_atlas(
atlas = "t",
type = "subcortical",
palette = c(a = "#aaaaaa", b = "#bbbbbb", ctx = "#cccccc"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
contextual <- atlas_region_contextual(atlas, "c")
expect_true("ctx" %in% contextual$data$geom$label)
expect_false("ctx" %in% contextual$core$label)
result <- atlas_context_remove(contextual)
expect_false("ctx" %in% result$data$geom$label)
expect_setequal(unique(result$data$geom$label), result$core$label)
})
})
describe("atlas_views on a polygon atlas", {
it("returns view names from polygon geometry", {
poly <- as_polygon_atlas(dk())
expect_setequal(atlas_views(poly), atlas_views(dk()))
})
})
describe("polygon-only view removal and keeping", {
it("removes views and warns when all views removed", {
poly <- as_polygon_atlas(dk())
result <- atlas_view_remove(poly, "lateral")
expect_null(result$data$sf)
expect_false("lateral" %in% atlas_views(result))
expect_true("medial" %in% atlas_views(result))
expect_warning(
expect_warning(
atlas_view_remove(poly, ".*"),
"All views removed",
fixed = TRUE
),
"no 2D geometry",
fixed = TRUE
)
})
it("warns when no views match on keep", {
poly <- as_polygon_atlas(dk())
expect_warning(
atlas_view_keep(poly, "zzz_nope"),
"No views matched",
fixed = TRUE
)
})
})
describe("atlas_region_contextual on a polygon atlas", {
it("keeps brain_polygons geometry and reorders context behind core", {
poly <- as_polygon_atlas(dk())
region <- unique(dk()$core$region)[1]
result <- atlas_region_contextual(poly, region)
expect_null(result$data$sf)
expect_s3_class(result$data$geom, "brain_polygons")
expect_false(region %in% result$core$region)
})
})
describe("atlas_view_gather sf early returns", {
make_sq <- function(x, y, s = 2) {
sf::st_polygon(list(matrix(
c(x, y, x + s, y, x + s, y + s, x, y + s, x, y),
ncol = 2,
byrow = TRUE
)))
}
it("returns the atlas unchanged when sf data has zero rows", {
sf_geom <- sf::st_sf(
label = "a",
view = "v1",
geometry = sf::st_sfc(make_sq(0, 0))
)
core <- data.frame(hemi = NA, region = "a", label = "a")
atlas <- ggseg_atlas(
atlas = "x",
type = "subcortical",
palette = c(a = "#aaaaaa"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
atlas$data$geom <- atlas$data$geom[0, , drop = FALSE]
expect_identical(atlas_view_gather(atlas), atlas)
})
it("casts a mixed-geometry sfc to multipolygon before packing", {
geom <- sf::st_sfc(
make_sq(0, 0),
sf::st_multipolygon(list(list(matrix(
c(2, 2, 3, 2, 3, 3, 2, 2),
ncol = 2,
byrow = TRUE
))))
)
expect_s3_class(geom, "sfc_GEOMETRY")
sf_geom <- sf::st_sf(
label = c("a", "b"),
view = c("v1", "v2"),
geometry = geom
)
core <- data.frame(
hemi = c(NA, NA),
region = c("a", "b"),
label = c("a", "b")
)
atlas <- ggseg_atlas(
atlas = "x",
type = "subcortical",
palette = c(a = "#aaaaaa", b = "#bbbbbb"),
core = core,
data = ggseg_data_subcortical(geom = sf_geom, meshes = NULL)
)
result <- atlas_view_gather(atlas)
expect_s3_class(result$data$geom, "sf")
})
})
describe("reposition_views early returns", {
it("returns the input when it is neither sf nor data.frame", {
expect_identical(reposition_views(1L:5L), 1L:5L)
})
it("returns the input when it has zero rows", {
empty <- data.frame(label = character(0), view = character(0))
expect_identical(reposition_views(empty), empty)
})
})
describe("rebuild_data_with_geom on a cerebellar atlas", {
it("preserves vertices and meshes after region removal", {
result <- atlas_region_remove(suit(), "I_IV")
expect_s3_class(result$data, "ggseg_data_cerebellar")
expect_false("I_IV" %in% result$core$region)
expect_false(is.null(result$data$vertices))
expect_false(is.null(result$data$meshes))
})
})
describe("view_remove_region_poly removing all geometry", {
it("warns when all region geometries are removed", {
poly <- as_polygon_atlas(dk())
expect_warning(
expect_warning(
atlas_view_remove_region(poly, ".*", match_on = "label"),
"All region geometries removed",
fixed = TRUE
),
"no 2D geometry",
fixed = TRUE
)
})
})
describe("view_reorder_poly with no matching views", {
it("warns and still returns a polygon atlas", {
poly <- as_polygon_atlas(dk())
expect_warning(
result <- atlas_view_reorder(poly, "zzz_nope"),
"No matching views",
fixed = TRUE
)
expect_null(result$data$sf)
})
})
describe("view_reorder_group_order across atlas types", {
it("returns the order unchanged for a non-cortical sf atlas", {
atlas <- as_sf_atlas(aseg())
views <- atlas_views(atlas)
result <- atlas_view_reorder(atlas, views[2])
expect_s3_class(result$data, "ggseg_data_subcortical")
expect_identical(unique(result$data$geom$view)[1], views[2])
})
it("expands a partial order into hemi groups for a cortical sf atlas", {
result <- atlas_view_reorder(as_sf_atlas(dk()), "lateral")
expect_identical(unique(result$data$geom$view)[1], "lateral")
})
})
describe("order_context_behind()", {
it("returns the geometry unchanged when it is NULL or empty", {
expect_null(order_context_behind(NULL, character(0)))
poly <- atlas_polygons(as_polygon_atlas(dk()))
empty <- poly[0, , drop = FALSE]
expect_identical(nrow(order_context_behind(empty, "lh_x")), 0L)
})
it("restores the brain_polygons class after reordering", {
poly <- atlas_polygons(as_polygon_atlas(dk()))
out <- order_context_behind(poly, poly$label[1:2])
expect_s3_class(out, "brain_polygons")
})
it("restores the class when a plain-data.frame backing drops it", {
plain <- structure(
data.frame(label = c("a", "b"), x = c(0, 1)),
class = c("brain_polygons", "data.frame")
)
out <- order_context_behind(plain, "a")
expect_s3_class(out, "brain_polygons")
})
})
describe("atlas_region_op() difference with no second operand", {
it("returns the first operand's geometry when y matches nothing", {
region <- unique(dk()$core$region)[1]
res <- atlas_region_op(
dk(),
x = region,
y = "zzz_no_such_region",
action = "difference",
into = "op_result",
match_on = "region"
)
expect_s3_class(res, "ggseg_atlas")
expect_true("op_result" %in% atlas_sf(res)$label)
})
})
describe("rebuild_data_with_geom() cerebellar vertices-only branch", {
it("rebuilds a cerebellar atlas that has vertices but no meshes", {
sf_geom <- sf::st_sf(
label = c("left_lobule", "right_lobule"),
view = c("lateral", "lateral"),
geometry = sf::st_sfc(make_polygon(), make_polygon2())
)
core <- data.frame(
hemi = c("left", "right"),
region = c("lobule", "lobule"),
label = c("left_lobule", "right_lobule")
)
vertices <- data.frame(label = c("left_lobule", "right_lobule"))
vertices$vertices <- list(1:3, 4:6)
cb <- ggseg_atlas(
atlas = "mini_cb",
type = "cerebellar",
core = core,
data = ggseg_data_cerebellar(geom = sf_geom, vertices = vertices)
)
res <- atlas_region_remove(cb, "left", match_on = "label")
expect_s3_class(res$data, "ggseg_data_cerebellar")
expect_null(res$data$meshes)
expect_false("left_lobule" %in% atlas_labels(res))
})
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.