Skip to content
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.

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

Ensure reproducible if using model cache #470

Open
wants to merge 3 commits into
base: main
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from 2 commits
Commits
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
21 changes: 20 additions & 1 deletion R/utilities.R
Original file line number Diff line number Diff line change
Expand Up @@ -556,11 +556,25 @@ clear_model_cache <- function(cache_dir = getOption("rbmi.cache_dir")) {
unlink(files)
}


#' Get Compiled Stan Object
#'
#' Gets a compiled Stan object that can be used with `rstan::sampling()`
#' @keywords internal
get_stan_model <- function() {

# Compiling Stan models updates the current seed state. This can lead to
# non-reproducibility as compiling is conditional on wether there is a cached
# model available or not. Thus we save the current seed state and restore it
# at the end of this function so that it is in the same state regardless of
# whether the model was compiled or not.
# See https://github.com/insightsengineering/rbmi/issues/469
# Note that .Random.seed is only set if the seed has been set or if a random number
# has been generated.
if (exists(".Random.seed")) {
current_seed_state <- .Random.seed
gowerc marked this conversation as resolved.
Show resolved Hide resolved
}

ensure_rstan()
local_file <- file.path("inst", "stan", "MMRM.stan")
system_file <- system.file(file.path("stan", "MMRM.stan"), package = "rbmi")
Expand All @@ -580,11 +594,16 @@ get_stan_model <- function() {
file.copy(file_loc, model_file, overwrite = TRUE)
}

rstan::stan_model(
model <- rstan::stan_model(
file = model_file,
auto_write = TRUE,
model_name = "rbmi_mmrm"
)

if (exists("current_seed_state")) {
.Random.seed <- current_seed_state
}
return(model)
gowerc marked this conversation as resolved.
Show resolved Hide resolved
}


Expand Down
74 changes: 74 additions & 0 deletions tests/testthat/test-reproducibility.R
Original file line number Diff line number Diff line change
Expand Up @@ -126,3 +126,77 @@ test_that("bayes - set.seed produces identical results", {
})
expect_equal(x$samples, y$samples)
})


test_that("Results are if model is recompiled", {

skip_if_not(is_full_test())

run_test <- function() {
set.seed(4642)
sigma <- as_vcov(c(2, 1, 0.7), c(0.5, 0.3, 0.2))
dat <- get_sim_data(40, sigma, trt = 8) %>%
mutate(outcome = if_else(rbinom(n(), 1, 0.3) == 1, NA_real_, outcome))

dat_ice <- dat %>%
group_by(id) %>%
arrange(id, visit) %>%
filter(is.na(outcome)) %>%
slice(1) %>%
ungroup() %>%
select(id, visit) %>%
mutate(strategy = "JR")

vars <- set_vars(
outcome = "outcome",
group = "group",
strategy = "strategy",
subjid = "id",
visit = "visit",
covariates = c("age", "sex", "visit * group")
)

vars2 <- vars
vars2$covariates <- c("age", "sex")

set.seed(984)
drawobj <- suppressWarnings({
draws(
data = dat,
data_ice = dat_ice,
vars = vars,
method = method_bayes(n_samples = 20),
quiet = TRUE
)
})
imputeobj <- impute(draws = drawobj, references = c("A" = "B", "B" = "B"))
anaobj <- analyse(imputeobj, fun = rbmi::ancova, vars = vars2)
poolobj <- pool(results = anaobj)

## Tidy up things that will never be the same:
drawobj$formula <- NULL # Formulas contain environments specific to their build
drawobj$fit <- NULL # Bayes object has "fit" which contains a timestamp
anaobj$call <- NULL # Argument names are different (imputeobj2)

return(list(
draws = drawobj,
impute = imputeobj,
analyse = anaobj,
pool = poolobj
))
}

old_cache <- options("rbmi.cache_dir")
tmp_dir <- tempfile(tmpdir = tempdir(check = TRUE))
dir.create(tmp_dir)
options("rbmi.cache_dir" = tmp_dir)
results_no_cache <- run_test()
results_cache <- run_test() # Now rerun but using the same cache
options("rbmi.cache_dir" = old_cache)

expect_equal(results_no_cache$draws, results_cache$draws)
expect_equal(results_no_cache$impute, results_cache$impute)
expect_equal(results_no_cache$analyse, results_cache$analyse)
expect_equal(results_no_cache$pool, results_cache$pool)

})
Loading