Skip to content

Commit

Permalink
More collaborativly developed additions to the test coverage.
Browse files Browse the repository at this point in the history
  • Loading branch information
@jan-imbi
jan-imbi committed Jul 10, 2024
1 parent cbb87c0 commit 300fe7a
Show file tree
Hide file tree
Showing 6 changed files with 264 additions and 6 deletions.
10 changes: 8 additions & 2 deletions R/estimators.R
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
# nocov start
#' Statistics and Estimators of the adestr package
#'
#' The \code{\link{Statistic}} class is a parent class for the classes
Expand Down Expand Up @@ -508,6 +509,9 @@ setMethod("get_stagewise_estimators", signature("IntervalEstimator", "DataDistri
})


# nocov end


setClass("SampleMean", contains = "PointEstimator")
#' @rdname PointEstimator-class
#' @export
Expand Down Expand Up @@ -705,6 +709,7 @@ rb2_kv <- function(smean1, smean2, n1, n2, mu, sigma, two_armed, preimage,
vectorInterface = TRUE)$integral / denom
}

# nocov start
newrb2_kv <- function(smean, n1, n2, mu, sigma, two_armed, preimage,
tol = getOption("adestr_tol_inner", default = .adestr_options[["adestr_tol_inner"]]),
maxEval = getOption("adestr_maxEval_inner", default = .adestr_options[["adestr_maxEval_inner"]]),
Expand Down Expand Up @@ -772,7 +777,7 @@ crb2_kv <- function(smean1, smean2, n1, n2, mu, sigma, two_armed, preimage,
absError = absError,
vectorInterface = TRUE)$integral / denom
}

# nocov end
pseudorb2_kv <- function(design, smean1, smean2, n1, n2, mu, sigma, two_armed,
tol = getOption("adestr_tol_inner", default = .adestr_options[["adestr_tol_inner"]]),
maxEval = getOption("adestr_maxEval_inner", default = .adestr_options[["adestr_maxEval_inner"]]),
Expand Down Expand Up @@ -939,7 +944,7 @@ adoptr_alpha_shifted_design_kv <- function(design, shiftc1f, shiftc1e, shiftc2){
}
pr_es1 + pr_es2
}

# nocov start
setClass("LinearShiftRepeatedPValue", slots = c(wc1f="numeric", wc1e="numeric", wc2="numeric"), contains = "VirtualPValue")
#' @rdname PValue-class
#' @param wc1f slope of futility boundary change.
Expand Down Expand Up @@ -973,6 +978,7 @@ rp2_kv <- function(design, smean1, smean2, n1, n2, sigma, two_armed, wc1f=0, wc1
shiftc1e = diff*wc1e,
shiftc2 = diff*wc2)
}
# nocov end

p_ml <- function(design, smean, n, mu, sigma, two_armed, tol = getOption("adestr_tol_inner", default = .adestr_options[["adestr_tol_inner"]]), maxEval = getOption("adestr_maxEval_inner", default = .adestr_options[["adestr_maxEval_inner"]]), absError = getOption("adestr_absError_inner", default = .adestr_options[["adestr_absError_inner"]]), ...) {
design <- TwoStageDesignWithCache(design)
Expand Down
7 changes: 5 additions & 2 deletions R/n2c2_helpers.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,15 +16,15 @@ n2_preimage <- function(design, sigma = 1, two_armed = FALSE, smean_scale = FALS
xs[i] <- zf
} else{
sgn <- sign(ns[i] - ns[i-1L])
if (sgn>0){
if (sgn>0){ # nocov start
root <- uniroot(
function(x) {
(ns[i] - 1L + sgn * .Machine$double.eps^.6) - n2_extrapol(design, x)
},
c(x_candidates[csum[i-1L]], x_candidates[csum[i-1L]] + stepsize),
tol = .Machine$double.eps^.6
)
} else {
} else { # nocov end
root <- uniroot(
function(x) {
(ns[i] + sgn * .Machine$double.eps^.6) - n2_extrapol(design, x)
Expand Down Expand Up @@ -99,6 +99,8 @@ get_c2_extrapol_function <- function(design){
design@c2_pivots
))
}

# nocov start
get_n2_extrapol_function <- function(design){
if (length(design@n2_pivots)>1){
h <- (design@c1e - design@c1f) / 2
Expand All @@ -110,3 +112,4 @@ get_n2_extrapol_function <- function(design){
return(\(x) design@n2_pivots)
}
}
# nocov end
58 changes: 56 additions & 2 deletions tests/testthat/test_dsmean.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,22 @@ test_that("density of MLE sums up to one (normal distribution, one-armed)",
tolerance=1e-2
)
})

test_that("density of MLE sums up to one (normal distribution, one-armed) (exact=TRUE)",
{
expect_equal(
dsmean(
Normal(two_armed = FALSE),
designad,
.x <- seq(-2, 2, .h <- .01),
0,
1,
exact = TRUE,
combine_components = TRUE
) |> sum() * .h,
1,
tolerance=1e-2
)
})

test_that("density of MLE sums up to one (t distribution, one-armed)",
{
Expand All @@ -33,6 +48,23 @@ test_that("density of MLE sums up to one (t distribution, one-armed)",
)
})

test_that("density of MLE sums up to one (t distribution, one-armed) (exact=TRUE)",
{
expect_equal(
dsmean(
Student(two_armed = FALSE),
designad,
.x <- seq(-2, 2, .h <- .001),
0,
1,
exact = TRUE,
combine_components = TRUE
) |> sum() * .h,
1,
tolerance = 1e-2
)
})


test_that("density of MLE sums up to one (normal distribution, two-armed, treatment group)",
{
Expand All @@ -46,6 +78,18 @@ test_that("density of MLE sums up to one (normal distribution, two-armed, treatm
tolerance = 1e-2)
})

test_that("density of MLE sums up to one (normal distribution, two-armed, treatment group) (exact=TRUE)",
{
expect_equal(dsmeanT(Normal(),
designad,
.x <- seq(-2, 2, .h <- .01),
0,
1,
exact = TRUE) |> sum() * .h,
1,
tolerance = 1e-2)
})

test_that("density of MLE sums up to one (t distribution, two-armed, treatment group)",
{
expect_equal(dsmeanT(Student(),
Expand All @@ -58,7 +102,17 @@ test_that("density of MLE sums up to one (t distribution, two-armed, treatment g
tolerance = 1e-2)
})


test_that("density of MLE sums up to one (t distribution, two-armed, treatment group) (exact=TRUE)",
{
expect_equal(dsmeanT(Student(),
designad,
.x <- seq(-2, 2, .h <- .1),
0,
1,
exact = TRUE) |> sum()*.h,
1,
tolerance = 1e-2)
})



Expand Down
121 changes: 121 additions & 0 deletions tests/testthat/test_evaluate_estimator.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,127 @@ test_that("MSE of sample mean can be calculated without error.",
})


test_that("evaluate_estimator works on lists without error.",
{
expect_error(
evaluate_estimator(
score = list(Bias(), Variance()),
estimator = SampleMean(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)
,
NA
)
})



test_that("Bias of sample mean can be calculated without error.",
{
expect_error(
evaluate_estimator(
score = Bias(),
estimator = SampleMean(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)
,
NA
)
})

test_that("Coverage of NaiveCI can be calculated without error.",
{
expect_error(
evaluate_estimator(
score = Coverage(),
estimator = NaiveCI(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)
,
NA
)
expect_error(
evaluate_estimator(
score = SoftCoverage(),
estimator = NaiveCI(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)
,
NA
)
})



test_that("TestAgreement of NaiveCI can be calculated",
{
expect_lt(
evaluate_estimator(
score = TestAgreement(),
estimator = NaiveCI(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)@results$`Agreement with test decision`
,
1
)
})

test_that("TestAgreement of NaivePValue can be calculated",
{
expect_lt(
evaluate_estimator(
score = TestAgreement(),
estimator = NaivePValue(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)@results$`Agreement with test decision`
,
1
)
})


test_that("Centrality of SampleMean wrt. NaiveCI can be calculated",
{
expect_equal(
evaluate_estimator(
score = Centrality(interval = NaiveCI()),
estimator = SampleMean(),
data_distribution = Normal(),
design = designad,
mu = c(0.3),
sigma = 1,
exact = FALSE
)@results$Centrality
,
0
)
})





Expand Down
65 changes: 65 additions & 0 deletions tests/testthat/test_integrals.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,20 @@ test_that("integral over sample space is equal to 1 for case: known variance, on
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: known variance, one-armed (exact=TRUE)",
{
expect_equal(
int_kv(
design = designad,
mu = .3,
sigma = 2.1,
two_armed = FALSE,
exact = TRUE
)$overall_integral$integral,
1,
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: unknown variance, one-armed",
{
expect_equal(
Expand All @@ -23,6 +37,19 @@ test_that("integral over sample space is equal to 1 for case: unknown variance,
tolerance=1e-3
)
})
test_that("integral over sample space is equal to 1 for case: unknown variance, one-armed (exact=TRUE)",
{
expect_equal(
int_uv(
design = designad,
mu = 0.3,
sigma = 2.1,
two_armed = FALSE,
exact=TRUE)$overall_integral$integral,
1,
tolerance=1e-3
)
})
test_that("integral over sample space is equal to 1 for case: known variance, two-armed",
{
expect_equal(
Expand All @@ -35,6 +62,19 @@ test_that("integral over sample space is equal to 1 for case: known variance, tw
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: known variance, two-armed (exact=TRUE)",
{
expect_equal(
int_kv(
design = designad,
mu = .3,
sigma = 2.1,
two_armed = TRUE,
exact=TRUE)$overall_integral$integral,
1,
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: unknown variance, two-armed",
{
expect_equal(
Expand All @@ -47,6 +87,19 @@ test_that("integral over sample space is equal to 1 for case: unknown variance,
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: unknown variance, two-armed (exact=TRUE)",
{
expect_equal(
int_uv(
design = designad,
mu = .3,
sigma = 2.1,
two_armed = TRUE,
exact=TRUE)$overall_integral$integral,
1,
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: known variance, two-armed, full sampling distribution",
{
expect_equal(
Expand All @@ -58,6 +111,18 @@ test_that("integral over sample space is equal to 1 for case: known variance, tw
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: known variance, two-armed, full sampling distribution (exact=TRUE)",
{
expect_equal(
int_kv_full(
design = designad,
mu = .3,
sigma = 2.1,
exact=TRUE)$overall_integral$integral,
1,
tolerance=1e-5
)
})
test_that("integral over sample space is equal to 1 for case: unknown variance, two-armed, full sampling distribution",
{
expect_equal(
Expand Down
Loading

0 comments on commit 300fe7a

Please sign in to comment.