tests/testthat/test-delta.R

In insightsengineering/rbmi: Reference Based Multiple Imputation

suppressPackageStartupMessages({
    library(dplyr)
    library(testthat)
    library(tibble)
})


test_that("delta_template & delta_lagscale", {
    set.seed(101)

    visits <- c(
        "week 24",
        "week 52",
        "week 104",
        "week 208",
        "week 416"
    )
    n_vis <- length(visits)

    dat <- tibble(
        pt = factor(rep(c("Tom", "Harry"), each = n_vis), levels = c("Tom", "Harry")),
        out = c(1, NA, 3, NA, NA, NA, 5, NA, 6, 7),
        vis = factor(rep(visits, 2), levels = visits),
        grp = factor(rep(c("A", "B"), each = n_vis)),
        cov1 = rnorm(n_vis * 2),
        cov2 = rnorm(n_vis * 2)
    )

    vars <- set_vars(
        outcome = "out",
        visit = "vis",
        subjid = "pt",
        group = "grp",
        strata = NULL,
        covariates = c("cov1", "cov2", "cov1*cov2"),
        strategy = "strategy"
    )

    ices <- data.frame(
        pt = c("Tom", "Harry"),
        vis = c("week 208", "week 52"),
        strategy = c("JTR", "MAR"),
        stringsAsFactors = FALSE
    )

    longd <- longDataConstructor$new(
        data = dat,
        vars = vars
    )

    longd$set_strategies(ices)

    output_expected <- select(dat, pt, vis, grp) %>%
        mutate(
            is_mar  =     c(TRUE, TRUE, TRUE, FALSE, FALSE,    TRUE, TRUE, TRUE, TRUE, TRUE),
            is_missing =  c(FALSE, TRUE, FALSE, TRUE, TRUE,    TRUE, FALSE, TRUE, FALSE, FALSE),
            is_post_ice = c(FALSE, FALSE, FALSE, TRUE, TRUE,    FALSE, TRUE, TRUE, TRUE, TRUE),
            strategy = c(NA, "MAR", NA, "JTR", "JTR",    "MAR", NA, "MAR", NA, NA),
            delta = rep(0, n_vis * 2)
        ) %>%
        as.data.frame()

    expect_equal(
        delta_template(list(data = longd)),
        output_expected
    )

    dlag <- c(1, 2, 3, 4, 5)
    delta <- c(-3, -6, -6, -12, 1)

    output_expected2 <- output_expected %>%
        mutate(delta = c(0, 0, 0, -12, -10,     0, 0, -18, 0, 0))

    expect_equal(
        delta_template(list(data = longd), delta, dlag),
        output_expected2
    )
})


test_that("d_lagscale", {

    dlag <- c(1, 1, 1, 1)
    delta <- c(-3, -6, -6, -12)

    expect_equal(
        d_lagscale(delta, dlag, c(TRUE, TRUE, TRUE, TRUE)),
        c(-3, -9, -15, -27)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, TRUE, TRUE, TRUE)),
        c(0, -6, -12, -24)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, TRUE, TRUE)),
        c(0, 0, -6, -18)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, FALSE, TRUE)),
        c(0, 0, 0, -12)
    )

    dlag <- c(0, 1, 1, 1)
    delta <- c(-3, -6, -6, -12)

    expect_equal(
        d_lagscale(delta, dlag, c(TRUE, TRUE, TRUE, TRUE)),
        c(0, -6, -12, -24)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, TRUE, TRUE, TRUE)),
        c(0, 0, -6, -18)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, TRUE, TRUE)),
        c(0, 0, 0, -12)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, FALSE, TRUE)),
        c(0, 0, 0, 0)
    )


    dlag <- c(1, 0, 0, 0)
    delta <- c(10, 10, 10, 10)

    expect_equal(
        d_lagscale(delta, dlag, c(TRUE, TRUE, TRUE, TRUE)),
        c(10, 10, 10, 10)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, TRUE, TRUE, TRUE)),
        c(0, 10, 10, 10)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, TRUE, TRUE)),
        c(0, 0, 10, 10)
    )
    expect_equal(
        d_lagscale(delta, dlag, c(FALSE, FALSE, FALSE, TRUE)),
        c(0, 0, 0, 10)
    )


})





test_that("apply_delta", {

    ### Using delta = NULL results in no changes
    d1 <- tibble(
        out = c(1, 2, 3),
        v1 = c(1, 2, 3),
        v2 = c(1, 2, 3),
        id = c("c", "b", "a")
    )
    output_actual <- apply_delta(d1, group = "id", outcome = "out")
    expect_equal(d1, output_actual)

    delta <- tibble()
    output_actual <- apply_delta(d1, delta, group = "id", outcome = "out")
    expect_equal(d1, output_actual)


    ### Changes happen as expected
    delta <- tibble(
        id = c("b", "a", "d"),
        delta = c(1, 2, 3)
    )
    output_expected <- d1
    output_expected$out <- c(1, 3, 5)
    output_actual <- apply_delta(d1, delta, group = "id", outcome = "out")
    expect_equal(output_expected, output_actual, ignore_attr = TRUE)


    ### Changes based on multigroup
    delta <- tibble(
        id = c("b", "a", "d"),
        v1 = c(2, 9, 9),
        delta = c(1, 2, 3)
    )
    output_expected <- d1
    output_expected$out <- c(1, 3, 3)
    output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out")
    expect_equal(output_expected, output_actual, ignore_attr = TRUE)


    ### Duplicate IDs in original dataset work as expected
    d1 <- tibble(
        out = c(1, 2, 3, 4),
        v1 = c(1, 1, 1, 2),
        v2 = c(1, 2, 3, 4),
        id = c("c", "b", "a", "b")
    )
    delta <- tibble(
        id = c("b", "a", "d"),
        delta = c(1, 2, 3)
    )
    output_expected <- d1
    output_expected$out <- c(1, 3, 5, 5)
    output_actual <- apply_delta(d1, delta, group = c("id"), outcome = "out")
    expect_equal(output_expected, output_actual, ignore_attr = TRUE)
    expect_error(
        apply_delta(d1, delta, group = c("id", "v1"), outcome = "out"),
        regexp = "`v1` is not in `delta`"
    )

    delta <- tibble(
        id = c("b", "a", "d"),
        v1 = c(1, 2, 2),
        delta = c(1, 2, 3)
    )
    output_expected <- d1
    output_expected$out <- c(1, 3, 3, 4)
    output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out")
    expect_equal(output_expected, output_actual, ignore_attr = TRUE)

    delta <- tibble(
        id = c("b", "a", "d", "b"),
        v1 = c(2, 2, 2, 1),
        delta = c(1, 2, 3, 9)
    )
    output_expected <- d1
    output_expected$out <- c(1, 11, 3, 5)
    output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out")
    expect_equal(output_expected, output_actual, ignore_attr = TRUE)


    ### Duplicate Ids result in an error
    delta <- tibble(
        id = c("b", "a", "d", "b"),
        delta = c(1, 2, 3, 4)
    )
    expect_error(
        apply_delta(d1, delta, group = "id", outcome = "out"),
        "whilst applying delta"
    )
})



test_that("extract_imputed_dfs + delta", {

    set.seed(301)
    sigma <- as_vcov(c(6, 4, 4), c(0.5, 0.2, 0.3))
    dat <- get_sim_data(50, sigma)

    dat_ice <- dat %>%
        group_by(id) %>%
        arrange(desc(visit)) %>%
        slice(1) %>%
        ungroup() %>%
        mutate(strategy = "MAR")

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

    dobj <- draws(
        dat,
        dat_ice,
        vars = vars,
        method = method_approxbayes(n_samples = 5),
        quiet = TRUE
    )
    iobj <- impute(dobj, c("A" = "B", "B" = "B"))

    delta <- tibble(
        id = c("2", "2"),
        visit = c("visit_3", "visit_1"),
        delta = c(4, 7)
    )

    d1 <- extract_imputed_dfs(iobj, 1)[[1]]
    d2 <- extract_imputed_dfs(iobj, 1, delta = delta)[[1]]

    d1$outcome[c(4, 6)] <- d1$outcome[c(4, 6)]  + c(7, 4)
    expect_equal(d1, d2)

    ### check that extraction / imputation hasn't changed sort order
    d1 <- extract_imputed_dfs(iobj, 1)[[1]] %>%
        select(-id)

    expect_equal(d1, select(dat, -id) %>%  as.data.frame)

})