tests/testthat/test-fit_functions.R

In polle: Policy Learning

test_that("fit_functions handle multiple thresholds", {
    d <- sim_single_stage(200, seed = 1)
    pd <- policy_data(d,
        action = "A",
        covariates = list("Z", "B", "L"),
        utility = "U"
    )

    pl <- policy_learn(
        type = "blip",
        threshold = c(0, 1),
        control = control_blip()
    )

    expect_no_error(
      ff <- fit_functions(
        policy_data = pd,
        type = "dr",
        policy_learn = pl,
        g_models = g_glm(),
        g_full_history = FALSE,
        q_models = q_glm(),
        q_full_history = FALSE,
        c_full_history = FALSE,
        m_full_history = FALSE
      )
    )

    expect_is(ff$policy_object, class = "policy_object")
})

test_that("crossfit_functions has the expected outcome", {

  sim_two_stage_right_cens <- function(n = 1e4,
                                       par = c(gamma = 0.5,  beta = 1, zeta = 1),
                                       seed = NULL,
                                       action_model_1 = function(C_1, beta, ...)
                                         stats::rbinom(n = NROW(C_1), size = 1, prob = lava::expit(beta * C_1)),
                                       action_model_2 = function(C_2, beta, ...)
                                         stats::rbinom(n = NROW(C_1), size = 1, prob = lava::expit(beta * C_2)),
                                       deterministic_rewards = FALSE,
                                       cens_model = function(L, zeta, ...)
                                         stats::rbinom(n = NROW(L), size = 1, prob = lava::expit(zeta * abs(L)))) {
    d <- sim_two_stage(n = n)
    d$U <- d$U_1 + d$U_2 + d$U_3

    pd <- policy_data(data = d,
                      action = c("A_1", "A_2"),
                      baseline = c("B", "BB"),
                      covariates = list(L = c("L_1", "L_2"),
                                        C = c("C_1", "C_2")),
                      utility = "U")

    ld <- pd$stage_data
    ld[is.na(L), L := d[["L_3"]]]

    ## simulating the discrete right-censoring:
    delta <- rbinom(n = nrow(ld), size = 1, prob = cens_model(ld$L, zeta = par["zeta"]))

    ## adapting the data to the right-censoring process:
    ld[ , delta := delta]
    ld[ , delta := cumprod(delta), by = id]
    ld[ , tmp := cumsum(delta == 0), by = id]
    ld <- ld[tmp %in% c(0,1)]
    ld[ , tmp := NULL]
    ld[delta == 0, event := 2]
    ld[ , delta := NULL]
    ld[event == 2 & stage == 3, U := NA]
    ld[event == 2, A := NA]

    return(ld)
  }

  set.seed(1)
  ld <- sim_two_stage_right_cens(n = 1e2)
  pd <- policy_data(data = ld, type = "long", action = "A", time = "time", time2 = "time2")
  folds <- sample_folds(2, sample_size = 1e2)

  ## fit_g_functions:
  expect_no_error(
    gf <- crossfit_function(folds = folds,
                            policy_data = pd,
                            fun = fit_g_functions,
                            models = g_glm(~C),
                            full_history = FALSE,
                            save_cross_fit_models = TRUE)
  )

  sgf <- lapply(folds, function(f) {
    spd <- subset_id(pd, id = get_id(pd)[-f])
    sgf <- fit_g_functions(spd, g_models = g_glm(~C))
    return(sgf)
  })

  for (i in seq_along(sgf)) {
    tmp <- sgf[[i]]
    tmp2 <- gf$functions[[i]]

    expect_equal(tmp, tmp2)

    pred1 <- predict.nuisance_functions(tmp, new_policy_data =  subset_id(pd, id = folds[[i]]))
    pred2 <- gf$values[id %in% folds[[i]]]

    expect_equal(pred1, pred2)
  }
  rm(sgf, tmp, tmp2, pred1, pred2)


  ## fit_c_functions
  expect_no_error(
    cf <- crossfit_function(folds = folds,
                            policy_data = pd,
                            fun = fit_c_functions,
                            models = list(g_glm(~L), g_glm(~L), g_glm(~L)),
                            full_history = FALSE,
                            save_cross_fit_models = TRUE)
  )

  scf <- lapply(folds, function(f) {
    spd <- subset_id(pd, id = get_id(pd)[-f])
    scf <- fit_c_functions(spd, c_models = list(g_glm(~L), g_glm(~L), g_glm(~L)))
    return(scf)
  })

  for (i in seq_along(scf)) {
    tmp <- scf[[i]]
    tmp2 <- cf$functions[[i]]

    expect_equal(tmp, tmp2)

    pred1 <- predict.c_functions(tmp, new_policy_data =  subset_id(pd, id = folds[[i]]))
    pred2 <- cf$values[id %in% folds[[i]]]

    expect_equal(pred1, pred2)
  }
  rm(scf, cf, tmp, tmp2, pred1, pred2)

  ## fit_m_function
  expect_no_error(
    mf <- crossfit_function(folds = folds,
                            policy_data = pd,
                            fun = fit_m_function,
                            models = q_glm(~L),
                            full_history = FALSE,
                            save_cross_fit_models = TRUE)
  )

  smf <- lapply(folds, function(f) {
    spd <- subset_id(pd, id = get_id(pd)[-f])
    smf <- fit_m_function(spd, m_model = q_glm(~L))
    return(smf)
  })

  for (i in seq_along(smf)) {
    tmp <- smf[[i]]
    tmp2 <- mf$functions[[i]]

    expect_equal(tmp, tmp2)

    pred1 <- predict.m_function(tmp, new_policy_data =  subset_id(pd, id = folds[[i]]))
    pred2 <- mf$values[id %in% folds[[i]]]

    expect_equal(pred1, pred2)
  }


})