From 9bee4d64be71b8d699cb987f081dcf15b3e182a6 Mon Sep 17 00:00:00 2001 From: WongDWai Date: Fri, 3 Jul 2026 16:05:31 -0400 Subject: [PATCH 1/2] Hard-code seeds for test_superinfection.R --- tests/testthat/test_superinfection.R | 115 ++++++++++++++------------- 1 file changed, 61 insertions(+), 54 deletions(-) diff --git a/tests/testthat/test_superinfection.R b/tests/testthat/test_superinfection.R index 022e888..7c18a1e 100644 --- a/tests/testthat/test_superinfection.R +++ b/tests/testthat/test_superinfection.R @@ -4,7 +4,47 @@ ## Assumes test_Superinfection.yaml is in the same directory. ## Override with: SUPERINF_YAML=/path/to/file.yaml Rscript test_superinfection.R +library(testthat) library(twt) +library(yaml) +library(ape) + +# these aren't exported so copy them here for testing +.filter.firsts <- function(events) { + idx <- which(events$event == 'transmission') + first.idx <- sapply(split(idx, events$to.host[idx]), function(i) { + i[which.min(events$time[i])] + }) + remove <- idx[!is.element(idx, first.idx)] + if (length(remove) > 0) events[-remove, ] else events +} + +.relabel.nodes <- function(events, targets) { + n.inf <- table(events$to.host) + if (any(n.inf > 1)) { + stop("ERROR: .relabel.nodes assumes events have been filtered of superinfection events.") + } + events <- events[order(events$time), ] + nodes <- na.omit(unique(c(events$from.host, events$to.host))) + for (node in nodes) { + idx <- which(events$from.host == node | events$to.host == node) + new.node <- node + label <- 1 + for (i in idx) { + if (events$from.host[i] == node) events$from.host[i] <- new.node + if (events$event[i] == 'migration') { + if (events$to.comp[i] %in% names(targets)) { + new.node <- paste(node, "sample", sep="_") + } else { + new.node <- paste(node, label, sep="_") + label <- label + 1 + } + events$to.host[i] <- new.node + } + } + } + events +} SUPERINF_PATH <- Sys.getenv("SUPERINF_YAML", unset = "") if (!nzchar(SUPERINF_PATH)) { @@ -23,31 +63,16 @@ try_model <- function(path) { ) } -# find an outer tree that has at least one SI event and a single active root -.get_outer_with_superinfection <- function(mod, seeds = 1:500) { - for (s in seeds) { - set.seed(s) - dyn <- tryCatch(sim.dynamics(mod, max.attempts = 10), - warning = function(w) NULL, error = function(e) NULL) - if (is.null(dyn)) next - - outer <- tryCatch( - withCallingHandlers(sim.outer.tree(dyn), - warning = function(w) invokeRestart("muffleWarning")), - error = function(e) NULL) - if (is.null(outer)) next - - log <- outer$get.log() - si <- log[log$event == "transmission" & - !is.na(log$from.comp) & log$from.comp == "I" & - !is.na(log$to.comp) & log$to.comp == "I", ] - if (outer$get.active()$count.type() != 1) next - if (nrow(si) == 0) next - if (outer$get.sampled()$count.type() < 1) next - - return(list(outer = outer, dyn = dyn, seed = s, si_log = si)) - } - NULL +# seed 10 verified to produce an outer tree with SI events and sampled hosts +.get_outer_with_superinfection <- function(mod) { + set.seed(10) + dyn <- sim.dynamics(mod, max.attempts=10) + outer <- suppressWarnings(sim.outer.tree(dyn)) + log <- outer$get.log() + si <- log[log$event == "transmission" & + !is.na(log$from.comp) & log$from.comp == "I" & + !is.na(log$to.comp) & log$to.comp == "I", ] + list(outer=outer, dyn=dyn, seed=10, si_log=si) } .try_inner <- function(outer) { @@ -59,35 +84,20 @@ try_model <- function(path) { }) } +# seed 10 verified to produce a valid single-root outer tree with phylo .get_valid_phylo <- function(mod) { - for (s in c(21, 77, 99, 200, 300, 400, 500)) { - set.seed(s) - dyn <- tryCatch(sim.dynamics(mod, max.attempts = 10), warning = function(w) NULL) - if (is.null(dyn)) next - outer <- tryCatch( - withCallingHandlers(sim.outer.tree(dyn), - warning = function(w) invokeRestart("muffleWarning")), - error = function(e) NULL) - if (is.null(outer)) next - if (outer$get.active()$count.type() != 1) next - phy <- tryCatch(as.phylo(outer), error = function(e) NULL) - if (!is.null(phy)) return(list(phy = phy, outer = outer)) - } - NULL + set.seed(10) + dyn <- sim.dynamics(mod, max.attempts=10) + outer <- suppressWarnings(sim.outer.tree(dyn)) + phy <- as.phylo(outer) + list(phy=phy, outer=outer) } -.get_valid_outer <- function(mod, seeds = c(99, 21, 77, 42, 55, 100, 200)) { - for (s in seeds) { - set.seed(s) - dyn <- tryCatch(sim.dynamics(mod, max.attempts = 15), warning = function(w) NULL) - if (is.null(dyn)) next - outer <- tryCatch( - withCallingHandlers(sim.outer.tree(dyn), - warning = function(w) invokeRestart("muffleWarning")), - error = function(e) NULL) - if (!is.null(outer)) return(outer) - } - NULL +# seed 1 verified to produce a valid outer tree +.get_valid_outer <- function(mod) { + set.seed(1) + dyn <- sim.dynamics(mod, max.attempts=15) + suppressWarnings(sim.outer.tree(dyn)) } @@ -617,9 +627,6 @@ test_that("sim.inner.tree (20 replicates): at least one produces transmission ev expect_true(n_with_tx > 0) }) -# when a host is superinfected, incoming lineages can coalesce with either the -# original or the superinfecting lineage — so inner tree replicates on the same -# outer tree should vary in topology test_that("sim.inner.tree: replicates on SI outer tree show topological variation", { mod <- try_model(SUPERINF_INNER_PATH) result <- .get_outer_with_superinfection(mod) From 16fef1decb0fdc510951dbb45e33d19a1035ceca Mon Sep 17 00:00:00 2001 From: WongDWai Date: Fri, 3 Jul 2026 16:15:08 -0400 Subject: [PATCH 2/2] Hard-code seeds for test_superinfection.R --- tests/testthat/test_superinfection.R | 43 ++-------------------------- 1 file changed, 3 insertions(+), 40 deletions(-) diff --git a/tests/testthat/test_superinfection.R b/tests/testthat/test_superinfection.R index 7c18a1e..3418772 100644 --- a/tests/testthat/test_superinfection.R +++ b/tests/testthat/test_superinfection.R @@ -4,47 +4,7 @@ ## Assumes test_Superinfection.yaml is in the same directory. ## Override with: SUPERINF_YAML=/path/to/file.yaml Rscript test_superinfection.R -library(testthat) library(twt) -library(yaml) -library(ape) - -# these aren't exported so copy them here for testing -.filter.firsts <- function(events) { - idx <- which(events$event == 'transmission') - first.idx <- sapply(split(idx, events$to.host[idx]), function(i) { - i[which.min(events$time[i])] - }) - remove <- idx[!is.element(idx, first.idx)] - if (length(remove) > 0) events[-remove, ] else events -} - -.relabel.nodes <- function(events, targets) { - n.inf <- table(events$to.host) - if (any(n.inf > 1)) { - stop("ERROR: .relabel.nodes assumes events have been filtered of superinfection events.") - } - events <- events[order(events$time), ] - nodes <- na.omit(unique(c(events$from.host, events$to.host))) - for (node in nodes) { - idx <- which(events$from.host == node | events$to.host == node) - new.node <- node - label <- 1 - for (i in idx) { - if (events$from.host[i] == node) events$from.host[i] <- new.node - if (events$event[i] == 'migration') { - if (events$to.comp[i] %in% names(targets)) { - new.node <- paste(node, "sample", sep="_") - } else { - new.node <- paste(node, label, sep="_") - label <- label + 1 - } - events$to.host[i] <- new.node - } - } - } - events -} SUPERINF_PATH <- Sys.getenv("SUPERINF_YAML", unset = "") if (!nzchar(SUPERINF_PATH)) { @@ -627,6 +587,9 @@ test_that("sim.inner.tree (20 replicates): at least one produces transmission ev expect_true(n_with_tx > 0) }) +# when a host is superinfected, incoming lineages can coalesce with either the +# original or the superinfecting lineage — so inner tree replicates on the same +# outer tree should vary in topology test_that("sim.inner.tree: replicates on SI outer tree show topological variation", { mod <- try_model(SUPERINF_INNER_PATH) result <- .get_outer_with_superinfection(mod)