tests/testthat/test-suite.R

In GreedyExperimentalDesign: Greedy Experimental Design Construction

source("helper-package.R")
test_that("core functions work across sizes", {
  skip_on_cmd_check()
  with_immediate_failures({
    configs_raw = build_test_configs()
    config_keys = vapply(configs_raw, function(cfg) {
      paste(cfg$n, cfg$p, cfg$r, cfg$prop_T, sep = "|")
    }, character(1))
    configs = configs_raw[!duplicated(config_keys)]
    B_values = sort(unique(vapply(configs_raw, function(cfg) cfg$B, numeric(1))))
    objectives = c("abs_sum_diff", "mahal_dist")

    for (objective in objectives) {
      for (cfg in configs) {
        if (objective == "mahal_dist" && cfg$p >= 10) { #too slow
          next
        }
        X = make_X(cfg$n, cfg$p, seed = cfg$seed)
        X1 = X[, 1, drop = FALSE]
        max_vectors = max(1L, min(as.integer(cfg$r), 10L))
        cat(
          "objective=", objective,
          " n=", cfg$n,
          " p=", cfg$p,
          " r=", cfg$r,
          " prop_T=", cfg$prop_T,
          " seed=", cfg$seed,
          "\n",
          sep = ""
        )

    Xstd = standardize_data_matrix(X)
    expect_equal(dim(Xstd), dim(X))
    expect_true(all(abs(colMeans(Xstd)) < 1e-10))
    expect_true(all(abs(apply(Xstd, 2, sd) - 1) < 1e-10))

    Xgen = generate_stdzied_design_matrix(n = cfg$n, p = cfg$p, covariate_gen = rnorm)
    expect_equal(dim(Xgen), dim(X))
    expect_true(all(abs(colMeans(Xgen)) < 1e-10))

    w = 1:cfg$n
    w1 = shuffle_cpp_wrap(w, seed = cfg$seed)
    w2 = shuffle_cpp_wrap(w, seed = cfg$seed)
    expect_equal(w1, w2)
    expect_equal(sort(w1), w)
    expect_true(all_elements_same_cpp_wrap(rep(2, 5)))
    expect_false(all_elements_same_cpp_wrap(c(1, 2, 1)))

    Xsmall = matrix(c(0, 0, 1, 1, 2, 2), ncol = 2, byrow = TRUE)
    D = compute_distance_matrix_cpp_wrap(Xsmall)
    expect_equal(dim(D), c(3, 3))
    expect_true(is.na(diag(D)[1]))
    expect_equal(D[1, 2], D[2, 1])
    K = compute_gram_matrix(Xsmall, kernel_type = "vanilla")
    expect_equal(dim(K), c(3, 3))
    expect_equal(K, t(K))

    indic = c(rep(1, cfg$n / 2), rep(0, cfg$n / 2))
    obj_val = compute_objective_val(
      X,
      indic,
      objective = objective,
      use_safe_inverse = TRUE
    )
    expect_true(is.numeric(obj_val))

    designs = complete_randomization(n = cfg$n, r = cfg$r)
    metrics = compute_randomization_metrics(t(designs))
    expect_true(is.list(metrics))
    expect_equal(dim(metrics$p_hat_ijs), c(cfg$n, cfg$n))
    expect_true(is.numeric(metrics$rand_entropy_metric))

    mat = complete_randomization(n = cfg$n, r = cfg$r)
    expect_binary_matrix(mat, nrow_expected = cfg$r, ncol_expected = cfg$n)

    forced = complete_randomization_with_forced_balanced(n = cfg$n, r = cfg$r, seed = cfg$seed)
    expect_binary_matrix(forced, nrow_expected = cfg$r, ncol_expected = cfg$n)
    expect_equal(rowSums(forced), rep(cfg$n / 2, cfg$r))

    imbal = imbalanced_complete_randomization(n = cfg$n, prop_T = cfg$prop_T, r = cfg$r, seed = cfg$seed)
    expect_binary_matrix(imbal, nrow_expected = cfg$r, ncol_expected = cfg$n)
    n_T = as.integer(round(cfg$n * cfg$prop_T))
    expect_equal(rowSums(imbal), rep(n_T, cfg$r))

    for (B in B_values) {
      if (cfg$n %% B != 0) {
        next
      }
      n_B = cfg$n / B
      if (abs(n_B * cfg$prop_T - round(n_B * cfg$prop_T)) > 1e-8) {
        next
      }
      blocks = imbalanced_block_designs(
        n = cfg$n,
        prop_T = cfg$prop_T,
        B = B,
        r = cfg$r,
        seed = cfg$seed
      )
      expect_binary_matrix(blocks, nrow_expected = cfg$r, ncol_expected = cfg$n)
      expect_equal(rowSums(blocks), rep(n_T, cfg$r))

      dummy_block = rep(c(1, 0), length.out = cfg$n / B)
      block_designs = generate_block_design_cpp_wrap(B = B, nR = cfg$r, dummy_block = dummy_block)
      expect_equal(dim(block_designs), c(cfg$r, cfg$n))
      expect_equal(rowSums(block_designs), rep(sum(dummy_block) * B, cfg$r))

      SigmaW = gen_var_cov_matrix_block_designs(n = cfg$n, prop_T = cfg$prop_T, B = B)
      expect_equal(dim(SigmaW), c(cfg$n, cfg$n))
      expect_equal(SigmaW, t(SigmaW))
    }

    pairs = matrix(c(1, 2, 3, 4), ncol = 2, byrow = TRUE)
    Wpm = gen_pm_designs_cpp_wrap(pairs, n = 2, r = cfg$r)
    expect_equal(dim(Wpm), c(cfg$r, 4))
    expect_true(all(Wpm %in% c(-1, 1)))

    pCs = c(0.1, 0.2, 0.3, 0.4)
    pTs = c(0.9, 0.8, 0.7, 0.6)
    Wbin = matrix(c(1, 0, 1, 0, 0, 1, 0, 1), nrow = 2, byrow = TRUE)
    Y = create_all_ys_cpp_wrap(pCs, pTs, Wbin, two_n = 4, nY = 2)
    expect_equal(dim(Y), c(2, 4))
    expect_true(is.logical(Y))

    res1 = optimize_asymmetric_treatment_assignment(n = cfg$n)
    expect_equal(res1$nT + res1$nC, cfg$n)
    res2 = optimize_asymmetric_treatment_assignment(n = cfg$n, c_treatment = 2, c_control = 1)
    expect_equal(res2$nT + res2$nC, cfg$n)
    expect_true(res2$nT > res2$nC)

    if (cfg$n >= 4) {
      Xhad = X[1:4, , drop = FALSE]
      W = hadamardExperimentalDesign(Xhad, strict = TRUE, form = "one_zero")
      expect_true(is.matrix(W))
      expect_true(all(W %in% c(0, 1)))
      expect_true(all(rowSums(W) == nrow(Xhad) / 2))
    }

    r_cur = max(2, cfg$r)
    Wcur = matrix(sample(c(-1, 1), r_cur * cfg$n, replace = TRUE), nrow = r_cur, ncol = cfg$n)
    res_cur = greedy_orthogonalization_curation(Wcur, Rmin = 2, verbose = FALSE)
    expect_true(is.list(res_cur))
    expect_equal(ncol(res_cur$Wsorted), cfg$n)
    R0 = min(max(2, floor(r_cur / 2)), r_cur)
    Wcur2 = greedy_orthogonalization_curation2(Wcur, R0 = R0, verbose = FALSE)
    expect_true(is.matrix(Wcur2))
    expect_equal(ncol(Wcur2), cfg$n)

    ged = initGreedyExperimentalDesignObject(
      X,
      max_designs = cfg$r,
      objective = objective,
      diagnostics = TRUE,
      wait = TRUE,
      num_cores = 1,
      seed = cfg$seed,
      verbose = FALSE,
      use_safe_inverse = TRUE
    )
    expect_output(print(ged))
    expect_output(summary(ged))
    res_greedy = resultsGreedySearch(ged, max_vectors = max_vectors)
    expect_binary_matrix(res_greedy$ending_indicTs, nrow_expected = max_vectors, ncol_expected = cfg$n)
    expect_equal(rowSums(res_greedy$ending_indicTs), rep(cfg$n / 2, max_vectors))
    with_plot_device(plot_obj_val_by_iter(res_greedy))
    with_plot_device(plot_obj_val_order_statistic(ged, order_stat = 1, skip_every = 1))
    with_plot_device(plot(ged))

    mk = suppressWarnings(initGreedyMultipleKernelExperimentalDesignObject(
      X,
      max_designs = cfg$r,
      kernel_pre_num_designs = cfg$r,
      kernel_names = c("mahalanobis", "gaussian"),
      wait = TRUE,
      num_cores = 1,
      seed = cfg$seed,
      diagnostics = TRUE,
      verbose = FALSE,
      use_safe_inverse = TRUE
    ))
    expect_output(print(mk))
    expect_output(summary(mk))
    res_mk = resultsMultipleKernelGreedySearch(mk, max_vectors = max_vectors, form = "one_zero")
    expect_binary_matrix(res_mk$ending_indicTs, nrow_expected = max_vectors, ncol_expected = cfg$n)
    expect_equal(rowSums(res_mk$ending_indicTs), rep(cfg$n / 2, max_vectors))
    with_plot_device(plot(mk))

    bms = computeBinaryMatchStructure(X, use_safe_inverse = TRUE)
    bms$verbose = FALSE
    bm_unique = 2^(cfg$n / 2)
    bm_max_designs = min(cfg$r, max(1L, floor(bm_unique / 2)))
    bm = initBinaryMatchExperimentalDesignSearchObject(
      bms,
      max_designs = bm_max_designs,
      wait = TRUE,
      num_cores = 1,
      seed = cfg$seed,
      verbose = FALSE
    )
    expect_output(print(bm))
    expect_output(summary(bm))
    res_bm = resultsBinaryMatchSearch(bm, form = "one_zero")
    expect_binary_matrix(res_bm, nrow_expected = bm_max_designs, ncol_expected = cfg$n)
    expect_equal(rowSums(res_bm), rep(cfg$n / 2, bm_max_designs))

    if (cfg$n %% 4 == 0) {
      bm_greedy = initBinaryMatchFollowedByGreedyExperimentalDesignSearchObject(
        X,
        diff_method = TRUE,
        max_designs = cfg$r,
        wait = TRUE,
        num_cores = 1,
        seed = cfg$seed,
        objective = objective,
        diagnostics = TRUE,
        verbose = FALSE
      )
      expect_output(print(bm_greedy))
      expect_output(summary(bm_greedy))
      res_bm_greedy = resultsBinaryMatchThenGreedySearch(
        bm_greedy,
        num_vectors = max_vectors,
        compute_obj_vals = TRUE,
        use_safe_inverse = TRUE
      )
      expect_binary_matrix(res_bm_greedy$indicTs, nrow_expected = max_vectors, ncol_expected = cfg$n)
      expect_equal(rowSums(res_bm_greedy$indicTs), rep(cfg$n / 2, max_vectors))

      bm_rerand = initBinaryMatchFollowedByRerandomizationDesignSearchObject(
        X,
        max_designs = cfg$r,
        wait = TRUE,
        num_cores = 1,
        seed = cfg$seed,
        objective = objective,
        obj_val_cutoff_to_include = Inf,
        verbose = FALSE
      )
      expect_output(print(bm_rerand))
      expect_output(summary(bm_rerand))
      res_bm_rerand = resultsBinaryMatchThenRerandomizationSearch(
        bm_rerand,
        num_vectors = max_vectors,
        compute_obj_vals = TRUE,
        use_safe_inverse = TRUE
      )
      expect_binary_matrix(res_bm_rerand$indicTs, ncol_expected = cfg$n)
      expect_true(nrow(res_bm_rerand$indicTs) >= max_vectors)
      expect_equal(rowSums(res_bm_rerand$indicTs), rep(cfg$n / 2, nrow(res_bm_rerand$indicTs)))
    } else {
      expect_error(
        initBinaryMatchFollowedByGreedyExperimentalDesignSearchObject(
          X,
          diff_method = TRUE,
          max_designs = cfg$r,
          wait = TRUE,
          num_cores = 1,
          seed = cfg$seed,
          objective = objective,
          diagnostics = TRUE,
          verbose = FALSE
        ),
        "divisible by four"
      )
      expect_error(
        initBinaryMatchFollowedByRerandomizationDesignSearchObject(
          X,
          max_designs = cfg$r,
          wait = TRUE,
          num_cores = 1,
          seed = cfg$seed,
          objective = objective,
          obj_val_cutoff_to_include = Inf,
          verbose = FALSE
        ),
        "divisible by four"
      )
    }

    rd = initRerandomizationExperimentalDesignObject(
      X,
      obj_val_cutoff_to_include = Inf,
      max_designs = cfg$r,
      objective = objective,
      wait = TRUE,
      num_cores = 1,
      seed = cfg$seed,
      verbose = FALSE,
      use_safe_inverse = TRUE
    )
    expect_output(print(rd))
    expect_output(summary(rd))
    res_rd = resultsRerandomizationSearch(rd, include_assignments = TRUE, form = "one_zero")
    expect_equal(dim(res_rd$ending_indicTs), c(cfg$r, cfg$n))
    expect_equal(rowSums(res_rd$ending_indicTs), rep(cfg$n / 2, cfg$r))

    Xopt = X[1:4, , drop = FALSE]
    if (objective == "abs_sum_diff" || cfg$p < nrow(Xopt)) {
      od = initOptimalExperimentalDesignObject(
        Xopt,
        objective = objective,
        wait = TRUE,
        num_cores = 1,
        verbose = FALSE,
        use_safe_inverse = TRUE
      )
      expect_output(print(od))
      expect_output(summary(od))
      res_opt = resultsOptimalSearch(od, num_vectors = 2, form = "one_zero")
      expect_equal(dim(res_opt$indicTs), c(2, 4))
    }

    if (objective == "abs_sum_diff" && cfg$p == 1) {
      kd = initKarpExperimentalDesignObject(X1, wait = TRUE, balanced = TRUE, verbose = FALSE)
      expect_output(print(kd))
      expect_output(summary(kd))
      res_kd = resultsKarpSearch(kd)
      expect_equal(length(res_kd$indicT), cfg$n)
    }
      }
    }
  })
})