GithubHelp home page GithubHelp logo

boehringer-ingelheim / oncomsm Goto Github PK

View Code? Open in Web Editor NEW
8.0 8.0 1.0 25.25 MB

Bayesian multi-state models for the analysis of oncology trials

Home Page: https://boehringer-ingelheim.github.io/oncomsm/

License: Other

R 47.96% C++ 43.61% Stan 3.05% TeX 5.38%

oncomsm's People

Contributors

akktk avatar kkmann avatar lucas234567 avatar

Stargazers

avatar avatar avatar avatar

Watchers

avatar avatar avatar

oncomsm's Issues

add baseline covariates

Time-dependent covariates are a bit tricky to incorporate since they would require a joint longitudinal / multi-state model. Sex, treatment line etc. are fixed at baseline though and can be incorporated relatively simply. Since the model is not hazard-based, covariates would affect logodds of transition probabilities and the location parameter of the transition times.

Improve performance of forward sampling

The forward sampling is still implemented in R quite naively. We do not want to implement it in stan to keep inference and predictive sampling separate but this should really be implemented in C++ to speed things up a bit.

oncomsm/R/srp_model.R

Lines 65 to 187 in 59dbee9

.impute.srp_model <- function(model, data, nsim, parameter_sample, seed = NULL, ...) {
if (!is.null(seed)) {
set.seed(seed)
}
# TODO: convert data to matrix and process in c++
stopifnot(isa(parameter_sample, "stanfit"))
# extract subject and group id levels for conversion to and back from integer
subject_id_levels <- unique(as.character(data$subject_id))
group_id_levels <- attr(model, "group_id") # important to maintain ordering
# extract parameter matrices
p <- rstan::extract(parameter_sample, "p")[[1]]
scale <- rstan::extract(parameter_sample, "scale")[[1]]
shape <- rstan::extract(parameter_sample, "shape")[[1]]
data <- data %>%
arrange(.data$t_sot, .data$subject_id, (.data$t_min + .data$t_max)/2) %>%
mutate(
subject_id = as.integer(factor(as.character(.data$subject_id), levels = subject_id_levels)),
group_id = as.integer(factor(.data$group_id, levels = group_id_levels))
)
res <- tribble(
~subject_id, ~group_id, ~from, ~to, ~t_min, ~t_max, ~t_sot, ~iter
)
visit_spacing <- attr(model, "visit_spacing")
idx <- sample(1:dim(p)[1], size = nsim, replace = TRUE)
for (i in 1:nrow(data)) {
if (!is.na(data$to[i])) { # observed transition, nothing to sample
res <- bind_rows(res, tidyr::expand_grid(data[i, ], iter = 1:nsim))
} else { # a censored transition
for (j in 1:nsim) {
g <- data$group_id[i]
k <- idx[j]
sshape <- shape[k, g, ]
sscale <- scale[k, g, ]
if (data$from[i] == "stable") {
# first sample response/progression
pr_response_raw <- p[k, g] # use survival information!
pr_survival_response <- 1 - stats::pweibull(data$t_min[i] - data$t_sot[i], sshape[1], sscale[1])
pr_survival_progression <- 1 - stats::pweibull(data$t_min[i] - data$t_sot[i], sshape[2], sscale[2])
pr_response <- pr_response_raw * pr_survival_response / (
pr_response_raw * pr_survival_response +
(1 - pr_response_raw) * pr_survival_progression
)
response <- stats::rbinom(1, 1, pr_response)
if (response) {
# sample exact response time
t_response <- rtruncweibull(
sshape[1], scale = sscale[1], data$t_min[i], Inf # t_min since time of SoT is known
)
# apply visit scheme
n_visits_response <- t_response %/% visit_spacing[g]
tmin_response <- data$t_min[i] + visit_spacing[g] * n_visits_response
tmax_response <- data$t_min[i] + visit_spacing[g] * (n_visits_response + 1)
# sample subsequent progression,
dt_progression <- stats::rweibull(1, sshape[3], sscale[3])
# apply visit scheme
n_visits_progression <- (dt_progression + t_response) %/% visit_spacing[g]
tmin_progression <- data$t_min[i] + visit_spacing[g] * n_visits_progression
tmax_progression <- data$t_min[i] + visit_spacing[g] * (n_visits_progression + 1)
res <- bind_rows(
res, tribble(
~subject_id, ~group_id, ~from, ~to, ~t_min, ~t_max, ~t_sot, ~iter,
data$subject_id[i], g, "stable", "response", tmin_response, tmax_response, data$t_sot[i], j,
data$subject_id[i], g, "response", "progression", tmin_progression, tmax_progression, data$t_sot[i], j
)
)
} else { # sample progression directly
dt_progression <- rtruncweibull(
sshape[2], scale = sscale[2], data$t_min[i], Inf # t_min since time of SoT is known
)
# apply visit scheme
n_visits_progression <- dt_progression %/% visit_spacing[g]
tmin_progression <- data$t_min[i] + visit_spacing[g] * n_visits_progression
tmax_progression <- data$t_min[i] + visit_spacing[g] * (n_visits_progression + 1)
res <- bind_rows(
res, tribble(
~subject_id, ~group_id, ~from, ~to, ~t_min, ~t_max, ~t_sot, ~iter,
data$subject_id[i], g, "stable", "progression", tmin_progression, tmax_progression, data$t_sot[i], j
)
)
} # end stable -> progression
} # end from == 1
if (data$from[i] == "response") {
if (data$from[i - 1] != "stable" || data$subject_id[i - 1] != data$subject_id[i]) {
stop()
}
# sample exact response time
t_response <- rtruncweibull(
sshape[1], scale = sscale[1], data$t_min[i - 1], data$t_max[i - 1]
)
# sample progression time
dt_progression <- rtruncweibull(
sshape[3], scale = sscale[3], data$t_min[i] - t_response, Inf
)
# apply visit scheme
n_visits_progression <- dt_progression %/% visit_spacing[g]
tmin_progression <- data$t_min[i] + visit_spacing[g] * n_visits_progression
tmax_progression <- data$t_min[i] + visit_spacing[g] * (n_visits_progression + 1)
res <- bind_rows(
res, tribble(
~subject_id, ~group_id, ~from, ~to, ~t_min, ~t_max, ~t_sot, ~iter,
data$subject_id[i], g, "response", "progression", tmin_progression, tmax_progression, data$t_sot[i], j
)
)
} # end from == 2
} # end iterate of j
} # end if/else
} # end iteration over i
# convert subject and group id back
res <- res %>%
mutate(
subject_id = as.character(
factor(.data$subject_id, levels = seq_along(subject_id_levels), labels = subject_id_levels)
),
group_id = as.character(
factor(.data$group_id, levels = seq_along(group_id_levels), labels = group_id_levels)
)
)
return(res)
}

To work with rcpp we need to create the columns separately and then put them together as data.frame at the very end.

achieve 100% unit-test coverage

We should gradually increase the unit-test coverage up to 100%. Structural testing is done in vignettes for now, maybe additional pkgdown articles are required as well.

switch to beta prior for orr

Logodds might be more convenient to implement hierarchical borrowing; for now beta priros might make it more convenient to elicit priors though.

Recommend Projects

  • React photo React

    A declarative, efficient, and flexible JavaScript library for building user interfaces.

  • Vue.js photo Vue.js

    🖖 Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.

  • Typescript photo Typescript

    TypeScript is a superset of JavaScript that compiles to clean JavaScript output.

  • TensorFlow photo TensorFlow

    An Open Source Machine Learning Framework for Everyone

  • Django photo Django

    The Web framework for perfectionists with deadlines.

  • D3 photo D3

    Bring data to life with SVG, Canvas and HTML. 📊📈🎉

Recommend Topics

  • javascript

    JavaScript (JS) is a lightweight interpreted programming language with first-class functions.

  • web

    Some thing interesting about web. New door for the world.

  • server

    A server is a program made to process requests and deliver data to clients.

  • Machine learning

    Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.

  • Game

    Some thing interesting about game, make everyone happy.

Recommend Org

  • Facebook photo Facebook

    We are working to build community through open source technology. NB: members must have two-factor auth.

  • Microsoft photo Microsoft

    Open source projects and samples from Microsoft.

  • Google photo Google

    Google ❤️ Open Source for everyone.

  • D3 photo D3

    Data-Driven Documents codes.