tests/testthat/test-levelSceptical.R

In ReplicationSuccess: Design and Analysis of Replication Studies

test_that("Output of function 'levelSceptical' stays the same.", {
    # set all possible parameters
    grid_controlled <- expand.grid(
        alternative = c("two.sided", "one.sided"),
        type = "controlled",
        c = c(1e-5, 0.5, 1, 1.5, 5, 10),
        stringsAsFactors = FALSE
    )
    grid_rest <- expand.grid(
        alternative = c("two.sided", "one.sided"),
        type = c("nominal", "golden"),
        c = NA_real_,
        stringsAsFactors = FALSE
    )
    grid <- rbind(grid_rest, grid_controlled)
    # set level of replication success. Note: In the function definition
    # we do not allow 0 or 1 but anything in between
    level <- c(1e-6, 0.005, 0.01, 0.05, 0.1, 0.5, 0.999)
    out <- lapply(
        seq_len(nrow(grid)),
        function(i) {
            tryCatch({
                levelSceptical(
                    level = level,
                    alternative = grid[i, "alternative"],
                    type = grid[i, "type"],
                    c =  grid[i, "c"]
                )
            },
            warning = function(w) "warning!",
            error = function(e) "error!"
            )
        }
    )
    res <- list(
        c(1e-06, 0.005, 0.01, 0.05, 0.1, 0.5, 0.999),
        c(1e-06, 0.005, 0.01, 0.05, 0.1, 0.5, 0.999),
        c(0.000120273342410185, 0.0273312878015435, 0.0428682107732366,
          0.123358558704367, 0.195975110892562, 0.595937883003954, 0.999213848543629),
        c(9.31473875686863e-05, 0.0214341053866183, 0.0337101730585594,
          0.0979875554462809, 0.156848832934081, 0.5, 0.992437881245328),
        c(1e-06, 0.005, 0.01, 0.05, 0.1, 0.5, 0.999),
        "error!",
        c(0.0001230703125, 0.0231661522426465, 0.0362305332225521,
          0.104482884301164, 0.167564981493604, 0.544385476905582, 0.999),
        "error!",
        c(0.0003672109375, 0.0350797364800123, 0.0517578701184723,
          0.130619555416346, 0.197775154089893, 0.565160134707053, 0.999),
        "error!",
        c(0.000733421875000002, 0.0452158514769247, 0.0643804764006999,
          0.15008537065244, 0.219576651593275, 0.579869614260351, 0.999),
        "error!",
        c(0.00493656685712746, 0.0949127866342207, 0.12269147198411,
          0.228026183709154, 0.302377503301343, 0.633105985166959, 0.999),
        "error!",
        c(0.0130868106403446, 0.139897370649398, 0.172310755243015,
          0.285727684366346, 0.360418465338739, 0.668190405230152, 0.999),
        "error!"
    )
    expect_equal(out, res)
})

# Tests written by CM
test_that("alphaLevel and levelSceptical return the same.", {
    ## computes the required alphalevel to achieve a certain targetT1E for a given c
    alphaLevel <- function(c, alternative = "one.sided", targetT1E){
        mylower <- sqrt(targetT1E)
        if (alternative == "one.sided")
            myupper <- 0.5
        if (alternative == "two.sided")
            myupper <- 1 - .Machine$double.eps^0.25
        res <- uniroot(
            ReplicationSuccess:::target, lower = mylower, upper = myupper,
            alternative = alternative, c = c,targetT1E = targetT1E
        )
        return(res$root)
    }
    # parameter grid
    grid <- expand.grid(
        level = seq(1e-6, 1 - 1e-6, length.out = 3L),
        c = seq(1e-2, 5, length.out = 4L),
        alternative = c("one.sided", "two.sided"),
        stringsAsFactors = FALSE
    )
    out <- vapply(
        seq_len(nrow(grid)),
        function(i) {
            tryCatch({
                c(
                    "alphaLevel" = alphaLevel(
                        c = grid[i, "c"], alternative = grid[i, "alternative"],
                        targetT1E = grid[i, "level"]^2
                    ),
                    "levelSceptical" = levelSceptical(
                        level = grid[i, "level"], c = grid[i, "c"],
                        alternative = grid[i, "alternative"], type = "controlled"
                    )
                )
            },
            warning = function(w) rep(NA_real_, 2L),
            error = function(e) rep(NA_real_, 2L)
            )
        },
        double(2L)
    )
    # remove cases that throw errors
    out <- out[, !apply(out, 2L, function(x) all(is.na(x)))]
    expect_true(all(apply(out, 2L, diff) == 0))
})