testthat::test_that("priority_queue constructor and length", { q0 <- priority_queue() testthat::expect_true(inherits(q0, "priority_queue")) testthat::expect_true(inherits(q0, "flexseq")) testthat::expect_identical(length(q0), 0L) q <- priority_queue("a", "b", "c", priorities = c(3, 1, 2)) testthat::expect_identical(length(q), 3L) testthat::expect_equal(peek_min(q), "b") testthat::expect_equal(peek_max(q), "a") }) testthat::test_that("empty priority_queue scalar peek/pop are non-throwing misses", { x <- priority_queue() testthat::expect_null(peek_min(x)) testthat::expect_null(peek_max(x)) testthat::expect_null(min_priority(x)) testthat::expect_null(max_priority(x)) pmin <- pop_min(x) pmax <- pop_max(x) testthat::expect_null(pmin$value) testthat::expect_null(pmin$priority) testthat::expect_identical(length(pmin$remaining), 0L) testthat::expect_null(pmax$value) testthat::expect_null(pmax$priority) testthat::expect_identical(length(pmax$remaining), 0L) }) testthat::test_that("min_priority/max_priority read cached extrema", { q <- priority_queue("a", "b", "c", priorities = c(3, 1, 2)) testthat::expect_identical(min_priority(q), 1) testthat::expect_identical(max_priority(q), 3) }) testthat::test_that("min/max pop uses sequence order on ties", { q <- priority_queue("a", "b", "c", "d", priorities = c(2, 1, 1, 2)) e1 <- pop_min(q) testthat::expect_equal(e1$value, "b") testthat::expect_equal(e1$priority, 1) e2 <- pop_min(e1$remaining) testthat::expect_equal(e2$value, "c") testthat::expect_equal(e2$priority, 1) x1 <- pop_max(q) testthat::expect_equal(x1$value, "a") testthat::expect_equal(x1$priority, 2) x2 <- pop_max(x1$remaining) testthat::expect_equal(x2$value, "d") testthat::expect_equal(x2$priority, 2) }) testthat::test_that("bulk extrema helpers return full tie runs", { q <- priority_queue("a", "b", "c", "d", priorities = c(2, 1, 1, 2)) pmin <- peek_all_min(q) pmax <- peek_all_max(q) testthat::expect_s3_class(pmin, "priority_queue") testthat::expect_s3_class(pmax, "priority_queue") testthat::expect_equal(lapply(as.list(pmin), function(e) e$value), list("b", "c")) testthat::expect_equal(lapply(as.list(pmax), function(e) e$value), list("a", "d")) out_min <- pop_all_min(q) testthat::expect_s3_class(out_min$elements, "priority_queue") testthat::expect_s3_class(out_min$remaining, "priority_queue") testthat::expect_equal(lapply(as.list(out_min$elements), function(e) e$value), list("b", "c")) testthat::expect_equal(lapply(as.list(out_min$remaining), function(e) e$value), list("a", "d")) out_max <- pop_all_max(q) testthat::expect_s3_class(out_max$elements, "priority_queue") testthat::expect_s3_class(out_max$remaining, "priority_queue") testthat::expect_equal(lapply(as.list(out_max$elements), function(e) e$value), list("a", "d")) testthat::expect_equal(lapply(as.list(out_max$remaining), function(e) e$value), list("b", "c")) }) testthat::test_that("bulk extrema single-element removal preserves pq measures", { q <- priority_queue("a", "b", "c", priorities = c(3, 1, 2)) out_min <- pop_all_min(q) testthat::expect_equal(lapply(as.list(out_min$elements), function(e) e$value), list("b")) testthat::expect_equal(peek_min(out_min$remaining), "c") testthat::expect_equal(peek_max(out_min$remaining), "a") testthat::expect_no_error(capture.output(print(out_min$remaining))) out_max <- pop_all_max(q) testthat::expect_equal(lapply(as.list(out_max$elements), function(e) e$value), list("a")) testthat::expect_equal(peek_min(out_max$remaining), "b") testthat::expect_equal(peek_max(out_max$remaining), "c") testthat::expect_no_error(capture.output(print(out_max$remaining))) }) testthat::test_that("as.list.priority_queue returns entry records in queue sequence order", { q <- as_priority_queue( setNames(as.list(c("x", "y", "z")), c("kx", "ky", "kz")), priorities = c(2, 1, 3) ) out <- as.list(q) testthat::expect_type(out, "list") testthat::expect_identical(names(out), c("kx", "ky", "kz")) testthat::expect_equal(unname(lapply(out, function(e) e$value)), list("x", "y", "z")) testthat::expect_equal(unname(lapply(out, function(e) e$priority)), as.list(c(2, 1, 3))) }) testthat::test_that("insert is persistent and supports names", { q <- as_priority_queue(setNames(as.list(c("x", "y")), c("kx", "ky")), priorities = c(5, 1)) q2 <- insert(q, "z", priority = 1, name = "kz") testthat::expect_equal(peek_min(q), "y") testthat::expect_equal(peek_min(q2), "y") testthat::expect_equal(q2[["kz"]], "z") testthat::expect_equal(q2$kz, "z") testthat::expect_equal(length(q2), 3L) }) testthat::test_that("priority_queue disallows sequence-style mutation helpers", { q <- priority_queue("b", "c", priorities = c(2, 3)) testthat::expect_error(push_front(q, list(value = "a", priority = 1)), "Cast first") testthat::expect_error(push_back(q, list(value = "d", priority = 4)), "Cast first") testthat::expect_error(peek_front(q), "not supported for priority_queue") testthat::expect_error(peek_back(q), "not supported for priority_queue") testthat::expect_error(peek_at(q, 1), "not supported for priority_queue") testthat::expect_error(pop_front(q), "not supported for priority_queue") testthat::expect_error(pop_back(q), "not supported for priority_queue") testthat::expect_error(pop_at(q, 1), "not supported for priority_queue") testthat::expect_error(insert_at(q, 1, "x"), "not supported for priority_queue") testthat::expect_error(c(q, q), "Cast first") }) testthat::test_that("priority_queue character subset is strict on missing names", { q <- as_priority_queue( setNames(as.list(c("a", "b", "c")), c("ka", "kb", "kc")), priorities = c(3, 1, 2) ) s <- q[c("kb", "ka")] testthat::expect_s3_class(s, "priority_queue") testthat::expect_equal(peek_min(s), "b") testthat::expect_error(q[c("kb", "missing")], "Unknown element name") }) testthat::test_that("priority_queue disallows positional/logical indexing and replacements", { q <- priority_queue("a", "b", priorities = c(2, 1)) testthat::expect_error(q[[1]], "scalar character names only") testthat::expect_error(q[1:2], "character name indexing only") testthat::expect_error(q[c(TRUE, FALSE)], "character name indexing only") testthat::expect_error({ q[[1]] <- list(value = "x", priority = 5) }, "Cast first") testthat::expect_error({ q[c(1, 2)] <- list("u", "v") }, "Cast first") }) testthat::test_that("priority queue carries required monoids", { q <- priority_queue(1, 2, priorities = c(10, 20)) ms <- names(attr(q, "monoids", exact = TRUE)) testthat::expect_true(all(c(".size", ".named_count", ".pq_min", ".pq_max") %in% ms)) }) testthat::test_that("priority_queue casts down to flexseq explicitly", { sum_priority <- measure_monoid(`+`, 0, function(entry) as.numeric(entry$priority)) q_named <- add_monoids( as_priority_queue(setNames(as.list(c("x", "y")), c("kx", "ky")), priorities = c(2, 1)), list(sum_priority = sum_priority) ) x <- as_flexseq(q_named) testthat::expect_s3_class(x, "flexseq") testthat::expect_false(inherits(x, "priority_queue")) testthat::expect_equal(x[["kx"]], "x") testthat::expect_equal(x[["ky"]], "y") ms <- names(attr(x, "monoids", exact = TRUE)) testthat::expect_true(all(c(".size", ".named_count") %in% ms)) testthat::expect_false(".pq_min" %in% ms) testthat::expect_false(".pq_max" %in% ms) testthat::expect_false("sum_priority" %in% ms) testthat::expect_error(node_measure(x, "sum_priority"), "Missing cached measure") x_unnamed <- as_flexseq(priority_queue("x", "y", priorities = c(2, 1))) x2 <- push_back(x_unnamed, "z") testthat::expect_s3_class(x2, "flexseq") testthat::expect_equal(length(x2), 3L) }) testthat::test_that("fapply maps priority queue items with read-only metadata", { q <- priority_queue("a", "bb", "ccc", priorities = c(1, 3, 2)) q2 <- fapply( q, function(value, priority, name) { toupper(value) } ) testthat::expect_equal(peek_min(q2), "A") testthat::expect_equal(peek_max(q2), "BB") testthat::expect_identical(length(q2), 3L) pmin <- pop_min(q2) pmax <- pop_max(q2) testthat::expect_identical(pmin$priority, 1) testthat::expect_identical(pmax$priority, 3) }) testthat::test_that("fapply respects sequence order for ties", { q <- as_priority_queue( c("a", "b", "c"), priorities = c(1, 1, 1) ) q2 <- fapply(q, function(value, priority, name) toupper(value)) # All priorities tie; left-most in sequence wins. testthat::expect_equal(peek_min(q2), "A") p1 <- pop_min(q2) p2 <- pop_min(p1$remaining) testthat::expect_equal(p1$value, "A") testthat::expect_equal(p2$value, "B") }) testthat::test_that("fapply preserves priority queue entry names", { q <- as_priority_queue(setNames(as.list(c("x", "y")), c("kx", "ky")), priorities = c(2, 1)) q2 <- fapply(q, function(value, priority, name) { paste(name, value, sep = ":") }) testthat::expect_equal(q2[["kx"]], "kx:x") testthat::expect_equal(q2[["ky"]], "ky:y") testthat::expect_equal(q2$kx, "kx:x") }) testthat::test_that("fapply can drop custom monoids for priority_queue", { sum_item <- measure_monoid(`+`, 0, function(entry) as.numeric(entry$value)) q <- add_monoids(priority_queue(1, 2, priorities = c(2, 1)), list(sum_item = sum_item)) q2 <- fapply(q, function(value, priority, name) value * 10, preserve_custom_monoids = FALSE) ms <- attr(q2, "monoids", exact = TRUE) testthat::expect_true(!is.null(ms[[".size"]])) testthat::expect_true(!is.null(ms[[".named_count"]])) testthat::expect_true(!is.null(ms[[".pq_min"]])) testthat::expect_true(!is.null(ms[[".pq_max"]])) testthat::expect_true(is.null(ms[["sum_item"]])) testthat::expect_error(node_measure(q2, "sum_item"), "Missing cached measure") testthat::expect_equal(peek_min(q2), 20) }) testthat::test_that("priority_queue custom monoids accept entry measure arguments", { q <- add_monoids( priority_queue(10, 20, priorities = c(2, 1)), list( by_priority = measure_monoid(`+`, 0, function(entry) as.numeric(entry$priority)) ) ) testthat::expect_equal(node_measure(q, "by_priority"), 3) }) testthat::test_that("fapply validates priority queue inputs", { q <- priority_queue("a", priorities = 1) testthat::expect_error(fapply.priority_queue(as_flexseq(1:3), FUN = identity), "`q` must be a priority_queue") testthat::expect_error(fapply(q, 1), "`FUN` must be a function") testthat::expect_error(fapply(q, identity, preserve_custom_monoids = NA), "`preserve_custom_monoids` must be TRUE or FALSE") }) testthat::test_that("priority_queue blocks split helpers and allows locate helper", { q <- priority_queue("a", "b", priorities = c(2, 1)) testthat::expect_error(split_by_predicate(q, function(v) v >= 1, ".size"), "Cast first") testthat::expect_error(split_around_by_predicate(q, function(v) v >= 1, ".size"), "Cast first") testthat::expect_error(split_at(q, 1), "Cast first") loc <- locate_by_predicate(q, function(v) v >= 1, ".size", include_metadata = TRUE) testthat::expect_true(loc$found) testthat::expect_identical(loc$value$value, "a") testthat::expect_identical(loc$metadata$index, 1L) }) testthat::test_that("priority_queue supports Date priorities with FIFO ties", { p <- as.Date(c("2024-01-03", "2024-01-01", "2024-01-01")) q <- priority_queue("late", "early1", "early2", priorities = p) testthat::expect_equal(peek_min(q), "early1") testthat::expect_equal(peek_max(q), "late") out1 <- pop_min(q) out2 <- pop_min(out1$remaining) testthat::expect_equal(out1$value, "early1") testthat::expect_equal(out2$value, "early2") testthat::expect_s3_class(out1$priority, "Date") testthat::expect_true(inherits(out2$priority, "Date")) q2 <- insert(q, "early3", priority = as.Date("2024-01-01")) testthat::expect_equal(pop_min(pop_min(q2)$remaining)$value, "early2") }) testthat::test_that("priority_queue supports POSIXct priorities with type-preserving pops", { p <- as.POSIXct( c("2024-01-01 12:00:00", "2024-01-01 10:00:00", "2024-01-01 10:00:00"), tz = "UTC" ) q <- priority_queue("late", "early1", "early2", priorities = p) testthat::expect_equal(peek_min(q), "early1") out <- pop_min(q) testthat::expect_equal(out$value, "early1") testthat::expect_s3_class(out$priority, "POSIXct") testthat::expect_s3_class(out$priority, "POSIXt") }) testthat::test_that("priority_queue rejects mixed priority domains and missing priorities", { testthat::expect_error( as_priority_queue(list("a", "b"), priorities = list(1, "1")), "Incompatible priority type" ) testthat::expect_error( as_priority_queue(list("a", "b"), priorities = list(1, as.Date("2024-01-01"))), "Incompatible priority type" ) testthat::expect_error( as_priority_queue( list("a", "b"), priorities = list(as.Date("2024-01-01"), as.POSIXct("2024-01-01 00:00:00", tz = "UTC")) ), "Incompatible priority type" ) q_num <- priority_queue("a", priorities = 1) q_date <- priority_queue("a", priorities = as.Date("2024-01-01")) testthat::expect_error(insert(q_num, "b", priority = "1"), "Incompatible priority type") testthat::expect_error(insert(q_num, "b", priority = as.Date("2024-01-01")), "Incompatible priority type") testthat::expect_error( insert(q_date, "b", priority = as.POSIXct("2024-01-01 00:00:00", tz = "UTC")), "Incompatible priority type" ) testthat::expect_error( priority_queue("a", priorities = as.Date(NA)), "`priority` must be non-missing" ) testthat::expect_error( insert(q_date, "b", priority = as.Date(NA)), "`priority` must be non-missing" ) })