Skip to content

assume no mixed readouts #89

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
saumil-sh wants to merge 2 commits into
base: test-Trial
Choose a base branch
from
+47 −28
Open

assume no mixed readouts #89

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
82fc96e
assume no mixed readouts
saumil-sh May 5, 2026
37c186d
add validation that compares n_readouts for all arms
saumil-sh May 5, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
26 changes: 14 additions & 12 deletions R/Trial.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -108,6 +108,16 @@ Trial <- R6::R6Class(
if (!is.null(timer) && !inherits(timer, "Timer")) stop("`timer` must be a Timer instance.")
stopifnot(is.list(population))

if (length(population) > 1) {
readouts <- sapply(population, function(p) p$n_readouts)
if (length(unique(readouts)) > 1) {
stop(sprintf(
"All populations must have the same n_readouts. Found: %s",
paste(sprintf("%s=%d", sapply(population, function(p) p$name), readouts), collapse = ", ")
))
}
}

if (is.null(timer) || length(timer$timelist) == 0) {
# If timer has no timepoints, extract from population enrollment times
if (all(sapply(population, function(x) all(is.na(x$enrolled))))) {
Expand Down Expand Up @@ -217,18 +227,10 @@ Trial <- R6::R6Class(
)
})

combined <- do.call(rbind, locked_snapshot_list)
offset <- 0L
global_ids <- integer(0)
for (idx in seq_along(self$population)) {
snap <- locked_snapshot_list[[idx]]
if (is.null(snap) || nrow(snap) == 0L) next
nr <- self$population[[idx]]$n_readouts
n_subj <- as.integer(nrow(snap) / nr)
global_ids <- c(global_ids, rep(offset + seq_len(n_subj), each = nr))
offset <- offset + n_subj
}
combined$subject_id <- global_ids
combined <- do.call(rbind, locked_snapshot_list)
nr <- self$population[[1]]$n_readouts
n_subj <- as.integer(nrow(combined) / nr)
combined$subject_id <- rep(seq_len(n_subj), each = nr)

if (is.null(combined) || nrow(combined) == 0L) {
next
Expand Down
49 changes: 33 additions & 16 deletions tests/testthat/test-Trial.R
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,19 +1,19 @@
test_that("Trial run: subject_id globally unique with mixed n_readouts across arms", {
# Arm A: 3 subjects, 1 readout each -> 3 rows
test_that("Trial run: subject_id globally unique across arms with same n_readouts", {
# Arm A: 3 subjects, 2 readouts each -> 6 rows
dataA <- data.frame(
id = c(1, 2, 3),
value = c(1, 2, 3),
readout_time = 0
id = rep(1:3, each = 2),
data = c(1, 1, 2, 2, 3, 3),
readout_time = rep(c(0, 1), 3)
)
popA <- Population$new("A", data = dataA, n_readouts = 1L)
popA <- Population$new("A", data = dataA)

# Arm B: 3 subjects, 2 readouts each -> 6 rows
dataB <- data.frame(
id = c(1, 1, 2, 2, 3, 3),
value = c(4, 4, 5, 5, 6, 6),
id = rep(1:3, each = 2),
data = c(4, 4, 5, 5, 6, 6),
readout_time = rep(c(0, 1), 3)
)
popB <- Population$new("B", data = dataB, n_readouts = 2L)
popB <- Population$new("B", data = dataB)

timer <- Timer$new("t")
timer$add_timepoint(time = 1, arm = "A", enroller = 3L, dropper = 0L)
Expand All @@ -22,7 +22,7 @@ test_that("Trial run: subject_id globally unique with mixed n_readouts across ar
trigger_by_calendar(1, timer, analysis = function(df, current_time) df)

trial <- Trial$new(
name = "mixed_readouts",
name = "two_arm_repeated",
seed = 1,
timer = timer,
population = list(popA, popB)
Expand All @@ -32,13 +32,30 @@ test_that("Trial run: subject_id globally unique with mixed n_readouts across ar

snap <- trial$locked_data[["time_1"]]

expect_equal(nrow(snap), 9L)
# 6 subjects x 2 readouts = 12 rows
testthat::expect_equal(nrow(snap), 12L)

# 6 globally unique subject IDs
testthat::expect_equal(sort(unique(snap$subject_id)), 1:6)
Copy link
Copy Markdown
Collaborator Author

@saumil-sh saumil-sh May 7, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

On a second thought, maybe better to remove unique from here
so we can check whether each vs times is correctly implemented
i.e. each 1,1,2,2,3,3,4,4,5,5,6,6 vs times 1,2,3,4,4,5,6,1,2,3,4,5,6

Copy link
Copy Markdown
Contributor

@mingstat mingstat May 11, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, that's a good idea.


# Each subject ID appears exactly 2 times (each, not cycled with times)
testthat::expect_true(all(table(snap$subject_id) == 2L))
})

expect_equal(sort(unique(snap$subject_id)), 1:6)
test_that("Trial initialize: errors when populations have different n_readouts", {
popA <- Population$new("A", data = data.frame(
id = 1:3, data = 1:3, readout_time = 0
))
popB <- Population$new("B", data = data.frame(
id = rep(1:3, each = 2), data = rep(1:3, each = 2), readout_time = rep(c(0, 1), 3)
))

rows_A <- snap[snap$subject_id %in% 1:3, ]
expect_true(all(table(rows_A$subject_id) == 1))
timer <- Timer$new("t")
timer$add_timepoint(time = 1, arm = "A", enroller = 3L, dropper = 0L)
timer$add_timepoint(time = 1, arm = "B", enroller = 3L, dropper = 0L)

rows_B <- snap[snap$subject_id %in% 4:6, ]
expect_true(all(table(rows_B$subject_id) == 2))
testthat::expect_error(
Trial$new(name = "bad_trial", timer = timer, population = list(popA, popB)),
"All populations must have the same n_readouts"
)
})
Loading