Nothing
suppressPackageStartupMessages({
library(dplyr)
library(testthat)
library(tibble)
})
test_that("Basic Usage", {
dat <- tibble(
subjid = factor(rep(c("Tom", "Harry", "Phil", "Ben"), each = 3), levels = c("Tom", "Harry", "Phil", "Ben")),
age = rep(c(0.04, -0.14, -0.03, -0.33), each = 3),
group = factor(rep(c("B", "B", "A", "A"), each = 3), levels = c("A", "B")),
sex = factor(rep(c("F", "M", "M", "F"), each = 3), levels = c("M", "F")),
strata = rep(c("A", "A", "A", "B"), each = 3),
visit = factor(rep(c("Visit 1", "Visit 2", "Visit 3"), 4)),
outcome = c(
NA, NA, NA,
NA, 4.14, NA,
NA, -1.34, 2.41,
-1.53, 1.03, 2.58
)
)
vars <- set_vars(
outcome = "outcome",
visit = "visit",
subjid = "subjid",
group = "group",
strata = "strata",
covariates = c("sex", "age"),
strategy = "strategy"
)
ld <- longDataConstructor$new(
data = dat,
vars = vars
)
beta <- c(-2.80, 4.93, 2.01, 4.66, 1.27, 3.14)
sigma <- list(
"A" = structure(c(1, 0.4, 1.2, 0.4, 4, 3.6, 1.2, 3.6, 9), .Dim = c(3L, 3L)),
"B" = structure(c(1, 0.4, 1.2, 0.4, 4, 3.6, 1.2, 3.6, 9), .Dim = c(3L, 3L))
)
draws_args <- list(
samples = sample_list(
sample_single(
ids = c("Tom", "Harry", "Phil", "Ben"),
beta = beta,
sigma = sigma
),
sample_single(
ids = c("Ben", "Ben", "Phil"),
beta = beta,
sigma = sigma
)
),
data = ld,
formula = x ~ y
)
draws_args$method <- method_approxbayes(n_samples = 2)
drawsObj1 <- do.call(as_draws, draws_args)
draws_args$method <- method_condmean(n_samples = 1)
drawsObj2 <- do.call(as_draws, draws_args)
set.seed(101)
x1 <- impute(draws = drawsObj1, references = c("A" = "A", "B" = "B"))
x2 <- impute(draws = drawsObj1, references = c("A" = "A", "B" = "B"))
x3 <- impute(draws = drawsObj2, references = c("A" = "A", "B" = "B"))
x4 <- impute(draws = drawsObj2, references = c("A" = "A", "B" = "B"))
expect_valid_structure <- function(x) {
for (i in x$imputations) {
for (j in i) {
cond1 <- all(names(j) %in% c("id", "values"))
cond2 <- is.character(j[["id"]]) & length(j[["id"]]) == 1
cond3 <- is.numeric(j[["values"]])
expect_true(cond1 & cond2 & cond3)
}
}
}
### The return object is in the expected format
expect_valid_structure(x1)
expect_valid_structure(x2)
expect_valid_structure(x3)
expect_valid_structure(x4)
### That conditional mean always returns the same deterministic value
expect_equal(x3, x4)
### That the Bayesian / bootstrap return different non-deterministic values
expect_false(identical(x1, x2))
expect_false(identical(x2, x3))
### That the sample names match those requested
samp_1_names <- vapply(x1$imputations[[1]], function(x) x$id, character(1))
samp_2_names <- vapply(x1$imputations[[2]], function(x) x$id, character(1))
real_1_names <- c("Tom", "Harry", "Phil", "Ben")
real_2_names <- c("Ben", "Ben", "Phil")
expect_equal(
samp_1_names[order(samp_1_names)],
real_1_names[order(real_1_names)]
)
expect_equal(
samp_2_names[order(samp_2_names)],
real_2_names[order(real_2_names)]
)
### That specific names have the correct number of missing values
expect_length(
Filter(function(x) x$id == "Tom", x1$imputations[[1]])[[1]]$values,
3
)
expect_length(
Filter(function(x) x$id == "Harry", x1$imputations[[1]])[[1]]$values,
2
)
expect_length(
Filter(function(x) x$id == "Phil", x1$imputations[[1]])[[1]]$values,
1
)
expect_length(
Filter(function(x) x$id == "Ben", x1$imputations[[1]])[[1]]$values,
0
)
})
test_that("`references` is handled as expected", {
set.seed(123)
n <- 8
nv <- 3
muT <- c(1,2,3)
muC <- c(1,3,5)
covC <- rbind(
c(2, 0.9, 0.8),
c(0.9, 2, 0.9),
c(0.8, 0.9, 2)
)
covT <- covC
dat <- data.frame(
subjid = factor(rep(1:(2*n), each = nv), levels = 1:(2*n)),
group = factor(rep(c("Control", "Intervention"), each = nv*n), levels = c("Control", "Intervention")),
visit = factor(rep(c("1", "2", "3"), 2*n), levels = c("1", "2", "3")),
outcome = c(
replicate(n, sample_mvnorm(muC, covC)),
replicate(n, sample_mvnorm(muT, covT))
)
)
dat$outcome[2:3] <- NA
method <- method_condmean(type = "bootstrap", n_samples = 0)
data_ice <- data.frame(
subjid = dat$subjid[c(1,10)],
visit = c("2", "3"),
strategy = "MAR"
)
vars <- set_vars()
drawsObj <- draws(dat, data_ice, vars, method, quiet = TRUE)
imputeObj <- impute(drawsObj)
references <- c(
"Control" = "Control",
"Intervention" = "Intervention"
)
imputeObj_expected <- impute(drawsObj, references = references)
expect_equal(
imputeObj,
imputeObj_expected
)
data_ice$strategy[1] <- "JR"
drawsObj <- draws(dat, data_ice, vars, method, quiet = TRUE)
expect_error(
impute(drawsObj),
"`references`"
)
references <- c(
"Control" = "Control",
"Intervention" = "Control"
)
imputeObj <- impute(drawsObj, references)
references <- add_class(references, "references")
expect_equal(
references,
imputeObj$references
)
})
test_that("transpose_samples", {
input <- list(
list(
ids = c("Tom", "Harry", "Phil", "Ben"),
beta = c(1, 2, 3),
sigma = list("A" = 9, "B" = 8, "C" = 7)
),
list(
ids = c("Adam", "Ben", "Ben", "Phil"),
beta = c(4, 5, 6),
sigma = list("A" = iris, "B" = 2, "C" = 3)
)
)
output_actual <- transpose_samples(input)
output_expected <- list(
beta = list(
c(1, 2, 3),
c(4, 5, 6)
),
sigma = list(
"A" = list(9, iris),
"B" = list(8, 2),
"C" = list(7, 3)
),
index = list(
"Tom" = c(1),
"Harry" = c(1),
"Phil" = c(1, 2),
"Ben" = c(1, 2, 2),
"Adam" = c(2)
)
)
expect_equal(output_actual, output_expected)
})
test_that("invert_indexes", {
input <- list(
c("Tom", "Harry", "Phil", "Ben", "Harry"),
c("Adam", "Ben", "Ben", "Phil")
)
output_actual <- invert_indexes(input)
output_expected <- list(
"Tom" = c(1),
"Harry" = c(1, 1),
"Phil" = c(1, 2),
"Ben" = c(1, 2, 2),
"Adam" = c(2)
)
expect_equal(output_actual, output_expected)
})
test_that("split_imputations", {
input_imputes <- list(
imputation_single("Ben", numeric(0)),
imputation_single("Ben", numeric(0)),
imputation_single("Ben", numeric(0)),
imputation_single("Harry", c(1, 2)),
imputation_single("Phil", c(3, 4)),
imputation_single("Phil", c(5, 6)),
imputation_single("Tom", c(7, 8, 9))
)
sample_ids <- list(
c("Ben", "Harry", "Phil", "Tom"),
c("Ben", "Ben", "Phil")
)
output_actual <- split_imputations(input_imputes, sample_ids)
output_expected <- list(
imputation_df(
imputation_single(id = "Ben", values = numeric(0)),
imputation_single(id = "Harry", values = c(1, 2)),
imputation_single(id = "Phil", values = c(3, 4)),
imputation_single(id = "Tom", values = c(7, 8, 9))
),
imputation_df(
imputation_single(id = "Ben", values = numeric(0)),
imputation_single(id = "Ben", values = numeric(0)),
imputation_single(id = "Phil", values = c(5, 6))
)
)
expect_equal(output_actual, output_expected)
sample_ids <- list(
c("Ben"),
c("Ben", "Ben", "Phil"),
c("Phil", "Tom"),
c("Harry")
)
output_actual <- split_imputations(input_imputes, sample_ids)
output_expected <- list(
imputation_df(
imputation_single(id = "Ben", values = numeric(0))
),
imputation_df(
imputation_single(id = "Ben", values = numeric(0)),
imputation_single(id = "Ben", values = numeric(0)),
imputation_single(id = "Phil", values = c(3, 4))
),
imputation_df(
imputation_single(id = "Phil", values = c(5, 6)),
imputation_single(id = "Tom", values = c(7, 8, 9))
),
imputation_df(
imputation_single(id = "Harry", values = c(1, 2))
)
)
expect_equal(output_actual, output_expected)
sample_ids <- list(
c("Ben"),
c("Ben", "Ben", "Phil", "Phil"),
c("Phil", "Tom"),
c("Harry")
)
expect_error(
split_imputations(input_imputes, sample_ids),
"index is not compatible with the object"
)
sample_ids <- list(
c("James"),
c("Ben", "Ben", "Phil"),
c("Phil", "Tom"),
c("Harry")
)
expect_error(
split_imputations(input_imputes, sample_ids),
"index is not compatible with the object"
)
sample_ids <- list(
c("Ben", "Phil"),
c("Phil", "Tom"),
c("Harry")
)
expect_error(
split_imputations(input_imputes, sample_ids),
"index is not compatible with the object"
)
# Check that output doesn't change as long as within-ID order is preserved
input_imputes_1 <- list(
imputation_single("Ben", 2),
imputation_single("Ben", 1),
imputation_single("Ben", c(1, 2)),
imputation_single("Harry", 3),
imputation_single("Phil", c(1, 2, 3)),
imputation_single("Phil", c(4, 5, 6))
)
input_imputes_2 <- list(
imputation_single("Ben", 2),
imputation_single("Phil", c(1, 2, 3)),
imputation_single("Harry", 3),
imputation_single("Ben", 1),
imputation_single("Phil", c(4, 5, 6)),
imputation_single("Ben", c(1, 2))
)
sample_ids <- list(
c("Phil", "Ben", "Ben", "Harry"),
c("Ben", "Phil")
)
output_actual_1 <- split_imputations(input_imputes_1, sample_ids)
output_actual_2 <- split_imputations(input_imputes_2, sample_ids)
output_expected <- list(
imputation_df(
imputation_single("Phil", c(1,2,3)),
imputation_single("Ben", 2),
imputation_single("Ben", 1),
imputation_single("Harry", 3)
),
imputation_df(
imputation_single("Ben", c(1,2)),
imputation_single("Phil", c(4,5,6))
)
)
expect_equal(output_actual_1, output_expected)
expect_equal(output_actual_2, output_expected)
})
test_that("get_conditional_parameters", {
input_pars <- list(
"mu" = c(2, 3, 4),
"sigma" = structure(c(1, 0.4, 1.2, 0.4, 4, 3.6, 1.2, 3.6, 9), .Dim = c(3L, 3L))
)
input_values <- c(NA, NA, 8)
output_actual <- get_conditional_parameters(input_pars, input_values)
output_expected <- list(
mu = structure(c(2.53333333333333, 4.6), .Dim = c(2L, 1L)),
sigma = structure(c(0.84, -0.0799999999999999, -0.08, 2.56), .Dim = c(2L, 2L))
)
expect_equal(output_actual, output_expected)
input_values <- c(NA, 8, NA)
output_actual <- get_conditional_parameters(input_pars, input_values)
output_expected <- list(
mu = structure(c(2.5, 8.5), .Dim = c(2L, 1L)),
sigma = structure(c(0.96, 0.84, 0.84, 5.76), .Dim = c(2L, 2L))
)
expect_equal(output_actual, output_expected)
input_values <- c(1, NA, 2)
output_actual <- get_conditional_parameters(input_pars, input_values)
output_expected <- list(
mu = structure(c(2.26984126984127), .Dim = c(1L, 1L)),
sigma = structure(c(2.55238095238095), .Dim = c(1L, 1L))
)
expect_equal(output_actual, output_expected)
### If all values are unknown then it should just return the full
### distribution as there is nothing to condition over
input_values <- c(NA, NA, NA)
output_actual <- get_conditional_parameters(input_pars, input_values)
output_expected <- input_pars
expect_equal(output_actual, output_expected)
### If all values are already available then return nothing as
### nothing needs to be imputed
input_values <- c(1, 2, 3)
output_actual <- get_conditional_parameters(input_pars, input_values)
output_expected <- list(mu = numeric(0), sigma = numeric(0))
expect_equal(output_actual, output_expected)
})
test_that("impute_outcome", {
##### Univariate
x <- impute_outcome(list(mu = 5, sigma = 10))
expect_length(x[[1]], 1)
expect_true(is.numeric(x[[1]]))
set.seed(101)
x <- unlist(replicate(n = 20000, impute_outcome(list(mu = 5, sigma = 10))))
mu <- mean(x)
sig <- sd(x)^2
expect_true(4.9 <= mu & mu <= 5.1)
expect_true(9.8 <= sig & sig <= 10.2)
##### Multivariate
# as_vcov( c(2, 4, 6), c(0.3, 0.5, 0.7)) %>% dput
pars <- list(
mu = c(8, 10, 12),
sigma = structure(c(4, 2.4, 6, 2.4, 16, 16.8, 6, 16.8, 36), .Dim = c(3L, 3L))
)
x <- unlist(impute_outcome(pars))
expect_length(x, 3)
expect_true(is.numeric(x))
set.seed(101)
vals <- replicate(n = 20000, impute_outcome(pars), simplify = FALSE)
x <- matrix(unlist(vals), ncol = 3, byrow = TRUE)
# Means
mu <- apply(x, 2, mean)
expect_true(all((pars$mu - 0.1) <= mu & mu <= (pars$mu + 0.1)))
# Variances
sig <- apply(x, 2, sd)
d_sig <- sqrt(diag(pars$sigma))
expect_true(all((d_sig - 0.1) <= sig & sig <= (d_sig + 0.1)))
# Correlations
corr <- cor(x)
corr_expec <- c(0.3, 0.5, 0.7)
corr_obs <- c(corr[1, 2], corr[1, 3], corr[2, 3])
expect_true(all((corr_obs - 0.1) <= corr_expec & corr_expec <= (corr_obs + 0.1)))
###### Non-compatible matrices
pars <- list(
mu = c(8, 10),
sigma = structure(c(4, 2.4, 6, 2.4, 16, 16.8, 6, 16.8, 36), .Dim = c(3L, 3L))
)
expect_error(
impute_outcome(pars),
regexp = "not of compatible sizes"
)
pars <- list(
mu = c(8),
sigma = structure(c(4, 2.4, 6, 2.4, 16, 16.8, 6, 16.8, 36), .Dim = c(3L, 3L))
)
expect_error(
impute_outcome(pars),
regexp = "not of compatible sizes"
)
pars <- list(
mu = c(8, 2),
sigma = 1
)
expect_error(
impute_outcome(pars),
regexp = "not of compatible sizes"
)
##### Missing value handling
pars <- list(
mu = c(2, NA),
sigma = 1
)
expect_error(
impute_outcome(pars),
regexp = "contain missing values"
)
pars <- list(
mu = c(1, 2, 4),
sigma = structure(c(4, 2.4, 6, 2.4, NA, 16.8, 6, 16.8, 36), .Dim = c(3L, 3L))
)
expect_error(
impute_outcome(pars),
regexp = "contain missing values"
)
pars <- list(
mu = c(NA),
sigma = 1
)
expect_error(
impute_outcome(pars),
regexp = "contain missing values"
)
pars <- list(
mu = c(1),
sigma = NA
)
expect_error(
impute_outcome(pars),
regexp = "contain missing values"
)
})
test_that("get_visit_distribution_parameters", {
beta <- list(c(1, 2, 3), c(4, 5, 6))
dat <- data.frame(a = c(1, 2), b = c(3, 4), c = c(5, 6))
sigma <- list(1, 5)
x <- get_visit_distribution_parameters(dat, beta, sigma)
expect_equal(
x[[1]]$mu,
c(1 * 1 + 2 * 3 + 3 * 5, 1 * 2 + 2 * 4 + 3 * 6)
)
expect_equal(
x[[2]]$mu,
c(4 * 1 + 5 * 3 + 6 * 5, 4 * 2 + 5 * 4 + 6 * 6)
)
expect_equal(x[[1]]$sigma, 1)
expect_equal(x[[2]]$sigma, 5)
beta <- list(c(1, 2, 3), c(4, 5, 6))
dat <- data.frame(a = c(1, 2), b = c(3, 4), c = c(5, 6))
sigma <- list(1)
expect_error(get_visit_distribution_parameters(dat, beta, sigma))
beta <- list(c(1, 2), c(4, 5))
dat <- data.frame(a = c(1, 2), b = c(3, 4), c = c(5, 6))
sigma <- list(1, 5)
expect_error(get_visit_distribution_parameters(dat, beta, sigma))
beta <- list(c(1, 2, 3), c(4, 5, 6))
dat <- data.frame(a = c(1, 2), b = c(3, 4))
sigma <- list(1, 5)
expect_error(get_visit_distribution_parameters(dat, beta, sigma))
beta <- list(c(1, 2, 3), c(4, 5))
dat <- data.frame(a = c(1, 2), b = c(3, 4), c = c(5, 6))
sigma <- list(1, 5)
expect_error(get_visit_distribution_parameters(dat, beta, sigma))
})
test_that("validate_strategies", {
dat <- tibble(
subjid = factor(rep(c("Tom", "Harry", "Phil", "Ben"), each = 3), levels = c("Tom", "Harry", "Phil", "Ben")),
age = rep(c(0.04, -0.14, -0.03, -0.33), each = 3),
group = factor(rep(c("B", "B", "A", "A"), each = 3), levels = c("A", "B")),
sex = factor(rep(c("F", "M", "M", "F"), each = 3), levels = c("M", "F")),
strata = rep(c("A", "A", "A", "B"), each = 3),
visit = factor(rep(c("Visit 1", "Visit 2", "Visit 3"), 4)),
outcome = c(
NA, NA, NA,
NA, 4.14, NA,
NA, -1.34, 2.41,
-1.53, 1.03, 2.58
)
)
vars <- set_vars(
outcome = "outcome",
visit = "visit",
subjid = "subjid",
group = "group",
strata = "strata",
covariates = c("sex", "age"),
strategy = "strategy"
)
ld <- longDataConstructor$new(
data = dat,
vars = vars
)
strats <- list("MAR" = function(x) x)
expect_true(validate_strategies(strats, ld$strategies))
expect_true(validate_strategies(strats, "MAR"))
expect_error(validate_strategies(strats, "NMAR"))
strats <- list("MAR" = function(x) x, "NMAR" = function(x) x)
expect_true(validate_strategies(strats, "NMAR"))
strats <- list("MAR" = function(x) x, "NMAR" = 1)
expect_error(validate_strategies(strats, "NMAR"))
strats <- c("NMAR")
expect_error(validate_strategies(strats, "NMAR"))
})
test_that("validate_references", {
control <- factor(c("A", "B", "C"), levels = c("A", "B", "C", "D"))
ref <- c("A" = "B") %>% as_class("references")
expect_true(validate(ref, control))
ref <- c("A" = "B", "C" = "A") %>% as_class("references")
expect_true(validate(ref, control))
ref <- c("A" = "B", "B" = "B", "C" = "C") %>% as_class("references")
expect_true(validate(ref, control))
ref <- c("X" = "A") %>% as_class("references")
expect_error(validate(ref, control))
ref <- c("A" = "X") %>% as_class("references")
expect_error(validate(ref, control))
ref <- c("A") %>% as_class("references")
expect_error(validate(ref, control))
ref <- c(1, 2, 3) %>% as_class("references")
expect_error(validate(ref, control))
ref <- factor("A") %>% as_class("references")
expect_error(validate(ref, control))
ref <- c("A" = NA, "B" = "C") %>% as_class("references")
expect_error(validate(ref, control))
ref <- c("A", "B" = "C") %>% as_class("references")
expect_error(validate(ref, control))
ref <- list() %>% as_class("references")
expect_error(validate(ref, control))
})
test_that("impute can recover known values", {
vars <- set_vars(
outcome = "outcome",
visit = "visit",
subjid = "id",
group = "group",
strategy = "strategy",
covariates = c("cov1", "cov1*group")
)
dat <- tibble(
visit = factor(rep(c("v1", "v2", "v3"), 4), levels = c("v1", "v2", "v3")),
id = factor(rep(c("1", "2", "3", "4"), each = 3)),
group = factor(rep(c("A", "B"), each = 6)),
cov1 = c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4),
outcome = c(1, NA, NA, 4, 3, 6, 1, 1, 1, 5, NA, 6)
)
ld <- longDataConstructor$new(dat, vars)
# 1 2 3 4 5 6
# outcome ~ 1 + group + visit + cov1 + cov1*group
dobj <- as_draws(
samples = sample_list(
sample_single(
ids = c("1", "2", "4"),
beta = c(1, 2, 3, 4, 5, 6),
sigma = list(
"A" = diag(c(1, 1, 1)),
"B" = diag(c(1, 1, 1))
)
)
),
data = ld,
method = method_condmean(n_samples = 4),
formula = x ~ y
)
x <- impute(dobj, c("A" = "B", "B" = "B"))
output_expected <- imputation_list_df(
imputation_df(
imputation_single("1", c(9, 10)),
imputation_single("2", as.matrix(numeric(0))),
imputation_single("4", c(50))
)
)
expect_equal(x$imputations, output_expected)
dobj$samples[[1]]$ids <- c("4", "4", "1", "3")
x <- impute(dobj, c("A" = "B", "B" = "B"))
output_expected <- imputation_list_df(
imputation_df(
imputation_single("4", c(50)),
imputation_single("4", c(50)),
imputation_single("1", c(9, 10)),
imputation_single("3", as.matrix(numeric(0)))
)
)
expect_equal(x$imputations, output_expected)
dobj$samples[[2]] <- sample_single(
ids = c("2", "1", "4"),
beta = c(6, 5, 4, 3, 2, 1),
sigma = list(
"A" = diag(c(1, 1, 1)),
"B" = diag(c(1, 1, 1))
)
)
x <- impute(dobj, c("A" = "B", "B" = "B"))
output_expected <- imputation_list_df(
imputation_df(
imputation_single("4", c(50)),
imputation_single("4", c(50)),
imputation_single("1", c(9, 10)),
imputation_single("3", as.matrix(numeric(0)))
),
imputation_df(
imputation_single("2", as.matrix(numeric(0))),
imputation_single("1", c(12, 11)),
imputation_single("4", c(27))
)
)
expect_equal(x$imputations, output_expected)
dat_ice <- tibble(
visit = "v3",
strategy = "JR",
id = "1"
)
ld <- longDataConstructor$new(dat, vars)
ld$set_strategies(dat_ice)
dobj <- as_draws(
samples = sample_list(
sample_single(
ids = c("1", "2", "4"),
beta = c(1, 2, 3, 4, 5, 6),
sigma = list(
"A" = diag(c(1, 1, 1)),
"B" = diag(c(1, 1, 1))
)
)
),
data = ld,
method = method_condmean(n_samples = 1),
formula = x~y
)
x <- impute(dobj, c("A" = "B", "B" = "B"))
output_expected <- imputation_list_df(
imputation_df(
imputation_single("1", c(9, 18)),
imputation_single("2", as.matrix(numeric(0))),
imputation_single("4", c(50))
)
)
expect_equal(x$imputations, output_expected)
})
test_that("convert_to_imputation_list_df works as expected", {
### Basic Usage
imputes <- list(
imputation_list_single(
imputations = list(
imputation_single("Tom", c(1)),
imputation_single("Tom", c(1,2)),
imputation_single("Tom", c(1,2,3)),
imputation_single("Tom", c(2)),
imputation_single("Tom", c(2,3)),
imputation_single("Tom", c(2,3,4))
),
D = 2
),
imputation_list_single(
imputations = list(
imputation_single("Harry", matrix(numeric(0))),
imputation_single("Harry", c(9, 8))
),
D = 2
)
)
sample_ids <- list(
c("Tom", "Harry", "Tom"),
c("Tom")
)
expected_output <- imputation_list_df(
imputation_df(
imputation_single("Tom", c(1)),
imputation_single("Harry", matrix(numeric(0))),
imputation_single("Tom", c(1, 2, 3))
),
imputation_df(
imputation_single("Tom", c(1, 2)),
imputation_single("Harry", c(9, 8)),
imputation_single("Tom", c(2))
),
imputation_df(
imputation_single("Tom", c(2, 3))
),
imputation_df(
imputation_single("Tom", c(2, 3, 4))
)
)
expect_equal(
convert_to_imputation_list_df(imputes, sample_ids),
expected_output
)
## Error handling
sample_ids <- list(
c("Tom", "Harry", "Dave"),
c("Tom")
)
expect_error(
convert_to_imputation_list_df(imputes, sample_ids),
regexp = "index is not compatible with the object"
)
sample_ids <- list(
c("Tom", "Harry", "Tom", "Tom"),
c("Tom")
)
expect_error(
convert_to_imputation_list_df(imputes, sample_ids),
regexp = "Number of samples available does not equal"
)
sample_ids <- list(
c("Tom", "Harry", "Harry"),
c("Tom")
)
expect_error(
convert_to_imputation_list_df(imputes, sample_ids),
regexp = "index is not compatible with the object"
)
})
test_that("method_bmlmi is working as expected in combination with impute", {
vars <- set_vars(
outcome = "outcome",
visit = "visit",
subjid = "id",
group = "group",
strategy = "strategy",
covariates = c("cov1", "cov1*group")
)
dat <- tibble(
visit = factor(rep(c("v1", "v2", "v3"), 4), levels = c("v1", "v2", "v3")),
id = factor(rep(c("PA", "PB", "PC", "PD"), each = 3)),
group = factor(rep(c("A", "B"), each = 6)),
cov1 = c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4),
outcome = c(1, NA, NA, 4, 3, 6, 1, 1, 1, 5, NA, 6)
)
sample_1_coef <- c(4, 2, 3, 4, 1, 2)
sample_2_coef <- c(9, 1, 1, 3, 4, 5)
model_mat <- model.matrix(~ 1 + group + visit + cov1 + cov1 * group, data = dat)
# Convienance dataset so we know what numbers to put down in the expected outcomes
dat2 <- dat %>%
mutate(expected_1 = model_mat %*% sample_1_coef %>% as.vector) %>%
mutate(expected_2 = model_mat %*% sample_2_coef %>% as.vector)
ld <- longDataConstructor$new(dat, vars)
## Use 0 correlation so that the conditional parameters doesn't change the
## expected mu and sigma parameters
dobj <- as_draws(
samples = sample_list(
sample_single(
ids = c("PA", "PB", "PD"),
beta = sample_1_coef,
sigma = list(
"A" = as_vcov(sd = c(1, 1, 1), cor = c(0, 0, 0)),
"B" = as_vcov(sd = c(1, 1, 1), cor = c(0, 0, 0))
)
),
sample_single(
ids = c("PC", "PA", "PA"),
beta = sample_2_coef,
sigma = list(
"A" = as_vcov(sd = c(1, 1, 1), cor = c(0, 0, 0)),
"B" = as_vcov(sd = c(1, 1, 1), cor = c(0, 0, 0))
)
)
),
data = ld,
method = method_bmlmi(B = 2, D = 3),
formula = x ~ y
)
expected_output <- imputation_list_df(
imputation_df(
imputation_single("PA", c(8, 9)),
imputation_single("PB", matrix(numeric(0))),
imputation_single("PD", 21)
),
imputation_df(
imputation_single("PA", c(8, 9)),
imputation_single("PB", matrix(numeric(0))),
imputation_single("PD", 21)
),
imputation_df(
imputation_single("PA", c(8, 9)),
imputation_single("PB", matrix(numeric(0))),
imputation_single("PD", 21)
),
imputation_df(
imputation_single("PC", matrix(numeric(0))),
imputation_single("PA", c(14, 16)),
imputation_single("PA", c(14, 16))
),
imputation_df(
imputation_single("PC", matrix(numeric(0))),
imputation_single("PA", c(14, 16)),
imputation_single("PA", c(14, 16))
),
imputation_df(
imputation_single("PC", matrix(numeric(0))),
imputation_single("PA", c(14, 16)),
imputation_single("PA", c(14, 16))
)
)
## We replace sample_mvnorm with our own function that essentially emulates
## conditional mean imputation so that we know what the results of the function
## will be
x <- with_mocking(
expr = {
impute(dobj, c("A" = "B", "B" = "B"))
},
sample_mvnorm = function(mu, sigma) as.vector(mu),
where = environment(impute)
)
expect_equal(x$imputations, expected_output)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.