Skip to content

Commit

Permalink
Convert summary.simtrial_gs_wlr() to data.table
Browse files Browse the repository at this point in the history
  • Loading branch information
@jdblischak
jdblischak committed Sep 27, 2024
1 parent 2ee0250 commit bb1b6fd
Show file tree
Hide file tree
Showing 4 changed files with 78 additions and 89 deletions.
2 changes: 2 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,10 @@ export(wlr)
importFrom(Rcpp,sourceCpp)
importFrom(data.table,":=")
importFrom(data.table,.N)
importFrom(data.table,.SD)
importFrom(data.table,as.data.table)
importFrom(data.table,data.table)
importFrom(data.table,dcast)
importFrom(data.table,fifelse)
importFrom(data.table,frankv)
importFrom(data.table,last)
Expand Down
10 changes: 5 additions & 5 deletions R/as_gt.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -120,17 +120,17 @@ as_gt.simtrial_gs_wlr <- function(x,
# build a gt table as return
ans <- x |>
gt::gt() |>
gt::tab_spanner(label = "Time", columns = ends_with("_time")) |>
gt::tab_spanner(label = "Events", columns = ends_with("_event")) |>
gt::tab_spanner(label = "N", columns = ends_with("_n")) |>
gt::tab_spanner(label = "Time", columns = gt::ends_with("_time")) |>
gt::tab_spanner(label = "Events", columns = gt::ends_with("_event")) |>
gt::tab_spanner(label = "N", columns = gt::ends_with("_n")) |>
gt::tab_spanner(
label = "Probability of crossing efficacy bounds under H1",
columns = ends_with("_upper_prob"))
columns = gt::ends_with("_upper_prob"))

if (design_type == "two-sided") {
ans <- ans |> gt::tab_spanner(
label = "Probability of crossing futility bounds under H1",
columns = ends_with("_lower_prob"))
columns = gt::ends_with("_lower_prob"))
}

ans |>
Expand Down
1 change: 1 addition & 0 deletions R/global.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,7 @@ utils::globalVariables(
"cte",
"cross_lower",
"cross_upper",
"cut_date",
"dropout_rate",
"dropout_time",
"duration",
Expand Down
154 changes: 70 additions & 84 deletions R/summary.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,9 @@
#'
#' @rdname summary
#' @return A data frame
#'
#' @importFrom data.table ":=" .N .SD as.data.table dcast merge.data.table
#'
#' @export
#'
#' @examples
Expand Down Expand Up @@ -94,120 +97,103 @@ summary.simtrial_gs_wlr <- function(object,
n_analysis <- nrow(object[object$sim_id == 1, ])
n_sim <- nrow(object) / n_analysis

object <- as.data.table(object)
# if the design input is NULL
# then simply output the simulated n, event, power
if (is.null(design)) {
ans1 <- object |>
dplyr::group_by(analysis) |>
dplyr::summarize(sim_n = mean(n), sim_event = mean(event), sim_time = mean(cut_date))
ans1 <- object[,
.(
sim_n = mean(n),
sim_event = mean(event),
sim_time = mean(cut_date)
),
by = "analysis"]

ans2 <- object |>
dplyr::left_join(data.frame(analysis = 1:n_analysis, upper_bound = bound)) |>
dplyr::mutate(cross_upper = z >= upper_bound) |>
dplyr::filter(cross_upper == TRUE) |>
dplyr::group_by(sim_id) |>
dplyr::filter(dplyr::row_number() == 1) |>
dplyr::ungroup() |>
dplyr::group_by(analysis) |>
dplyr::summarize(n_cross_upper = dplyr::n()) |>
dplyr::mutate(sim_upper_prob = cumsum(n_cross_upper) / n_sim) |>
dplyr::select(analysis, sim_upper_prob)
bound_dt <- data.table(analysis = 1:n_analysis, upper_bound = bound)
ans2 <- merge.data.table(object, bound_dt, all.x = TRUE, sort = FALSE)
ans2[, cross_upper := z >= upper_bound]
ans2 <- ans2[cross_upper == TRUE, ]
ans2 <- ans2[, .SD[1], by = "sim_id"]
ans2 <- ans2[, .(n_cross_upper = .N), by = "analysis"]
ans2 <- ans2[order(analysis),
.(analysis, sim_upper_prob = cumsum(n_cross_upper) / n_sim)]

suppressMessages(
ans <- ans1 |> dplyr::left_join(ans2)
)
ans <- merge.data.table(ans1, ans2, all.x = TRUE)

attr(ans, "compare_with_design") <- "no"
} else {
# get the design type, 1-sided or 2-sided
design_type <- ifelse(length(unique(design$bound$bound)) == 1, "one-sided", "two-sided")
design_type <- if(length(unique(design$bound$bound)) == 1) "one-sided" else "two-sided"

# add the futility and efficacy bounds to the simulation results
if (design_type == "one-sided") {
suppressMessages(
sim_tbl <- object |>
dplyr::left_join(
design$bound |>
dplyr::select(analysis, z, bound) |>
dplyr::rename(upper_bound = z)
) |>
dplyr::mutate(cross_upper = z >= upper_bound)
)
bound_dt <- as.data.table(design$bound)
bound_dt <- bound_dt[, .(analysis, upper_bound = z, bound)]
sim_tbl <- merge.data.table(object, bound_dt, all.x = TRUE, sort = FALSE)
sim_tbl[, cross_upper := z >= upper_bound]
} else {
suppressMessages(
sim_tbl <- object |>
dplyr::left_join(
design$bound |>
dplyr::select(analysis, z, bound) |>
tidyr::pivot_wider(values_from = z, names_from = bound) |>
dplyr::rename(lower_bound = lower, upper_bound = upper)
) |>
dplyr::mutate(cross_lower = z <= lower_bound,
cross_upper = z >= upper_bound)
)
bound_dt <- as.data.table(design$bound)
bound_dt <- dcast(bound_dt, analysis ~ bound, value.var = "z")
bound_dt <- bound_dt[, .(analysis, lower_bound = lower, upper_bound = upper)]

sim_tbl <- merge.data.table(object, bound_dt, all.x = TRUE, sort = FALSE)
sim_tbl[, cross_lower := z <= lower_bound]
sim_tbl[, cross_upper := z >= upper_bound]
}

# calculate the prob of crossing efficacy bounds
tbl_upper <- sim_tbl |>
dplyr::filter(cross_upper == TRUE) |>
dplyr::group_by(sim_id) |>
dplyr::filter(dplyr::row_number() == 1) |>
dplyr::ungroup() |>
dplyr::group_by(analysis) |>
dplyr::summarize(n_cross_upper = dplyr::n()) |>
dplyr::mutate(sim_upper_prob = cumsum(n_cross_upper) / n_sim) |>
dplyr::select(analysis, sim_upper_prob)
tbl_upper <- sim_tbl[cross_upper == TRUE, ]
tbl_upper <- tbl_upper[, .SD[1], by = "sim_id"]
tbl_upper <- tbl_upper[, .(n_cross_upper = .N), by = "analysis"]
tbl_upper <- tbl_upper[order(analysis),
.(analysis, sim_upper_prob = cumsum(n_cross_upper) / n_sim)]

# calculate the prob of crossing futility bounds
if (design_type == "two-sided") {
tbl_lower <- sim_tbl |>
dplyr::filter(cross_lower == TRUE) |>
dplyr::group_by(sim_id) |>
dplyr::filter(dplyr::row_number() == 1) |>
dplyr::ungroup() |>
dplyr::group_by(analysis) |>
dplyr::summarize(n_cross_lower = dplyr::n()) |>
dplyr::mutate(sim_lower_prob = cumsum(n_cross_lower) / n_sim) |>
dplyr::select(analysis, sim_lower_prob)
tbl_lower <- sim_tbl[cross_lower == TRUE, ]
tbl_lower <- tbl_lower[, .SD[1], by = "sim_id"]
tbl_lower <- tbl_lower[, .(n_cross_lower = .N), by = "analysis"]
tbl_lower <- tbl_lower[order(analysis),
.(analysis, sim_lower_prob = cumsum(n_cross_lower) / n_sim)]
}

# combining prob of crossing efficacy and futility bounds under H1
if (design_type == "one-sided") {
tbl_asy_prob <- design$bound |>
dplyr::select(analysis, probability) |>
dplyr::rename(asy_upper_prob = probability)
tbl_asy_prob <- as.data.table(design$bound)
tbl_asy_prob <- tbl_asy_prob[, .(analysis, asy_upper_prob = probability)]
} else {
tbl_asy_prob <- design$bound |>
dplyr::select(analysis, bound, probability) |>
tidyr::pivot_wider(values_from = probability, names_from = bound) |>
dplyr::rename(asy_upper_prob = upper, asy_lower_prob = lower)
tbl_asy_prob <- as.data.table(design$bound)
tbl_asy_prob <- dcast(tbl_asy_prob, analysis ~ bound, value.var = "probability")
tbl_asy_prob <- tbl_asy_prob[, .(analysis, asy_upper_prob = upper, asy_lower_prob = lower)]
}

# calculate the number of analysis time, events and sample size
suppressMessages(
tbl_event <- object |>
dplyr::group_by(analysis) |>
dplyr::summarize(sim_event = mean(event),
sim_n = mean(n),
sim_time = mean(cut_date)) |>
dplyr::right_join(design$analysis |>
dplyr::select(analysis, time, n, event) |>
dplyr::rename(asy_time = time, asy_n = n, asy_event = event))
)
tbl_event <- object[,
.(
sim_event = mean(event),
sim_n = mean(n),
sim_time = mean(cut_date)
),
by = "analysis"]
analysis_dt <- as.data.table(design$analysis)
analysis_dt <- analysis_dt[,
.(
analysis,
asy_time = time,
asy_n = n,
asy_event = event
)]
tbl_event <- merge.data.table(tbl_event, analysis_dt, all.y = TRUE, sort = FALSE)
# combine all the information together
if (design_type == "one-sided") {
suppressMessages(
ans <- tbl_asy_prob |>
dplyr::left_join(tbl_upper) |>
dplyr::left_join(tbl_event)
)
ans <- tbl_asy_prob |>
merge.data.table(tbl_upper, all.x = TRUE, sort = FALSE) |>
merge.data.table(tbl_event, all.x = TRUE, sort = FALSE)
} else {
suppressMessages(
ans <- tbl_asy_prob |>
dplyr::left_join(tbl_upper) |>
dplyr::left_join(tbl_lower) |>
dplyr::left_join(tbl_event)
)
ans <- tbl_asy_prob |>
merge.data.table(tbl_upper, all.x = TRUE, sort = FALSE) |>
merge.data.table(tbl_lower, all.x = TRUE, sort = FALSE) |>
merge.data.table(tbl_event, all.x = TRUE, sort = FALSE)
}

attr(ans, "compare_with_design") <- "yes"
Expand Down

0 comments on commit bb1b6fd

Please sign in to comment.