Nothing
dat.aov <- aov(Petal.Width ~ Species, data = iris)
# ============================================================================
# NEW TESTS FOR LIST STRUCTURE AND P-VALUE MATRIX
# ============================================================================
test_that("multiple_comparisons returns a list with correct structure", {
output <- multiple_comparisons(dat.aov, classify = "Species")
# Test that output is a list
expect_type(output, "list")
expect_s3_class(output, "mct")
# Test that all expected elements are present
expect_true("predictions" %in% names(output))
expect_true("pairwise_pvalues" %in% names(output))
expect_true("hsd" %in% names(output))
expect_true("sig_level" %in% names(output))
# Test that each element has the correct type
expect_s3_class(output$predictions, "data.frame")
expect_type(output$pairwise_pvalues, "double")
expect_true(is.matrix(output$pairwise_pvalues))
expect_type(output$hsd, "double")
expect_type(output$sig_level, "double")
})
test_that("predictions component has correct structure", {
output <- multiple_comparisons(dat.aov, classify = "Species")
pred <- output$predictions
# Check it's a data frame
expect_s3_class(pred, "data.frame")
# Check expected columns exist
expect_true("Species" %in% colnames(pred))
expect_true("predicted.value" %in% colnames(pred))
expect_true("std.error" %in% colnames(pred))
expect_true("low" %in% colnames(pred))
expect_true("up" %in% colnames(pred))
expect_true("groups" %in% colnames(pred))
# Check number of rows
expect_equal(nrow(pred), 3) # 3 species
# Check values are correct
expect_equal(pred$predicted.value, c(0.25, 1.33, 2.03), tolerance = 5e-2)
})
test_that("p-value matrix has correct properties", {
output <- multiple_comparisons(dat.aov, classify = "Species")
pvals <- output$pairwise_pvalues
# Check it's a matrix
expect_true(is.matrix(pvals))
# Check dimensions
expect_equal(nrow(pvals), 3)
expect_equal(ncol(pvals), 3)
# Check row and column names
expect_equal(rownames(pvals), c("setosa", "versicolor", "virginica"))
expect_equal(colnames(pvals), c("setosa", "versicolor", "virginica"))
# Check diagonal is 1 (no difference with itself)
expect_equal(diag(pvals), c(setosa=1, versicolor=1, virginica=1))
# Check all values are in [0, 1]
expect_true(all(pvals >= 0 & pvals <= 1))
# Check symmetry
expect_true(isSymmetric(pvals))
# Check that p-values match expected significance
# setosa vs versicolor should be significant (different groups)
expect_true(pvals["setosa", "versicolor"] < 0.05)
# setosa vs virginica should be significant
expect_true(pvals["setosa", "virginica"] < 0.05)
# versicolor vs virginica should be significant
expect_true(pvals["versicolor", "virginica"] < 0.05)
})
test_that("calculate_pvalue_matrix supports Matrix SED inputs", {
skip_if_not_installed("Matrix")
pp <- data.frame(
predicted.value = c(10, 12, 13, 15),
Names = c("A", "B", "C", "D")
)
sed_base <- matrix(0.5, nrow = 4, ncol = 4)
diag(sed_base) <- NA_real_
# Create a packed symmetric *dense* Matrix (dspMatrix).
# Using sparse=TRUE yields a dsCMatrix which cannot be coerced to dspMatrix.
sed_mat <- as(
Matrix::forceSymmetric(Matrix::Matrix(sed_base, sparse = FALSE), uplo = "U"),
"packedMatrix"
)
pvals <- biometryassist:::calculate_pvalue_matrix(pp, sed_mat, ndf = 10)
expect_true(is.matrix(pvals))
expect_type(pvals, "double")
expect_true(isSymmetric(pvals))
expect_equal(rownames(pvals), pp$Names)
expect_equal(colnames(pvals), pp$Names)
expect_true(all(pvals[upper.tri(pvals)] >= 0 & pvals[upper.tri(pvals)] <= 1, na.rm = TRUE))
})
test_that("calculate_pvalue_matrix supports scalar SED inputs", {
pp <- data.frame(
predicted.value = c(10, 12, 13, 15),
Names = c("A", "B", "C", "D")
)
# Scalar SED implies the same standard error for every comparison.
# This covers the `rep_len(sed, length(diff))` branch.
pvals <- biometryassist:::calculate_pvalue_matrix(pp, sed = 0.5, ndf = 10)
expect_true(is.matrix(pvals))
expect_type(pvals, "double")
expect_true(isSymmetric(pvals))
expect_equal(rownames(pvals), pp$Names)
expect_equal(colnames(pvals), pp$Names)
expect_equal(diag(pvals), rep(1, nrow(pp)), ignore_attr = TRUE)
expect_true(all(pvals[upper.tri(pvals)] >= 0 & pvals[upper.tri(pvals)] <= 1, na.rm = TRUE))
})
test_that("calculate_pvalue_matrix supports base-matrix SED inputs", {
pp <- data.frame(
predicted.value = c(10, 11, 15),
Names = c("A", "B", "C")
)
# A plain base matrix should take the `!is.null(dim(sed))` branch.
sed_mat <- matrix(0.5, nrow = 3, ncol = 3,
dimnames = list(pp$Names, pp$Names))
diag(sed_mat) <- NA_real_
pvals <- biometryassist:::calculate_pvalue_matrix(pp, sed = sed_mat, ndf = 10)
expect_true(is.matrix(pvals))
expect_type(pvals, "double")
expect_true(isSymmetric(pvals))
expect_equal(rownames(pvals), pp$Names)
expect_equal(colnames(pvals), pp$Names)
expect_equal(diag(pvals), rep(1, 3), ignore_attr = TRUE)
# Spot-check one expected p-value to ensure indexing is correct.
diff_ab <- abs(pp$predicted.value[1] - pp$predicted.value[2])
q_ab <- as.numeric(diff_ab / 0.5) * sqrt(2)
expected_ab <- stats::ptukey(q_ab, nmeans = 3, df = 10, lower.tail = FALSE)
expect_equal(pvals["A", "B"], expected_ab, tolerance = 1e-12)
})
test_that("calculate_pvalue_matrix returns a 1x1 matrix when n <= 1", {
pp <- data.frame(
predicted.value = 10,
Names = "A"
)
pvals <- biometryassist:::calculate_pvalue_matrix(pp, sed = 0.5, ndf = 10)
expect_true(is.matrix(pvals))
expect_equal(dim(pvals), c(1L, 1L))
expect_equal(rownames(pvals), "A")
expect_equal(colnames(pvals), "A")
expect_equal(pvals[1, 1], 1)
})
test_that("HSD value is accessible and correct", {
output <- multiple_comparisons(dat.aov, classify = "Species")
# Check HSD is numeric
expect_type(output$hsd, "double")
# Check HSD is positive
expect_true(output$hsd > 0)
# Check HSD is accessible via attribute for backward compatibility
expect_equal(attr(output, "HSD"), output$hsd)
})
test_that("sig_level is stored correctly", {
output1 <- multiple_comparisons(dat.aov, classify = "Species", sig = 0.05)
expect_equal(output1$sig_level, 0.05)
output2 <- multiple_comparisons(dat.aov, classify = "Species", sig = 0.01)
expect_equal(output2$sig_level, 0.01)
})
test_that("p-value matrix calculation with interaction terms", {
# Create data with two factors
set.seed(123)
factorial_data <- expand.grid(
Factor1 = factor(c("A", "B")),
Factor2 = factor(c("X", "Y")),
Rep = 1:5
)
factorial_data$Response <- rnorm(nrow(factorial_data),
mean = 50 + as.numeric(factorial_data$Factor1) * 10 +
as.numeric(factorial_data$Factor2) * 5,
sd = 5)
model_int <- aov(Response ~ Factor1 * Factor2, data = factorial_data)
output <- multiple_comparisons(model_int, classify = "Factor1:Factor2")
# Check matrix dimensions (2 * 2 = 4 combinations)
expect_equal(nrow(output$pairwise_pvalues), 4)
expect_equal(ncol(output$pairwise_pvalues), 4)
# Check row/column names are treatment combinations
expected_names <- c("A_X", "A_Y", "B_X", "B_Y")
expect_equal(sort(rownames(output$pairwise_pvalues)), sort(expected_names))
# Check matrix properties
expect_true(isSymmetric(output$pairwise_pvalues))
expect_equal(diag(output$pairwise_pvalues), rep(1, 4), ignore_attr = TRUE)
})
test_that("p-values without letter groups still calculated", {
output <- multiple_comparisons(dat.aov, classify = "Species", groups = FALSE)
# Check predictions doesn't have groups column
expect_false("groups" %in% colnames(output$predictions))
# Check p-value matrix is still created
expect_true("pairwise_pvalues" %in% names(output))
expect_true(is.matrix(output$pairwise_pvalues))
expect_equal(nrow(output$pairwise_pvalues), 3)
})
test_that("print.mct shows list structure information", {
output <- multiple_comparisons(dat.aov, classify = "Species")
# Capture print output
printed <- capture.output(print(output))
# Check for key elements in output
expect_true(any(grepl("Multiple Comparisons", printed)))
expect_true(any(grepl("Significance level", printed)))
expect_true(any(grepl("HSD", printed)))
expect_true(any(grepl("Predicted values", printed)))
})
test_that("aliased treatments in list structure", {
CO_2 <- CO2
CO_2$uptake[CO_2$Type=="Quebec" & CO_2$Treatment=="nonchilled"] <- NA
model <- aov(uptake~Type+Treatment+Type:Treatment, data = CO_2)
expect_warning(
output <- multiple_comparisons(model, classify = "Type:Treatment"),
"A level of Type\\:Treatment is aliased"
)
# Check aliased is stored in list
expect_true("aliased" %in% names(output))
expect_equal(output$aliased, "Quebec:nonchilled")
# Check aliased is also in attributes for backward compatibility
expect_equal(attr(output, "aliased"), "Quebec:nonchilled")
})
test_that("backward compatibility: attributes still accessible", {
output <- multiple_comparisons(dat.aov, classify = "Species")
# Check attributes that should be preserved
expect_false(is.null(attr(output, "ylab")))
expect_false(is.null(attr(output, "HSD")))
expect_equal(attr(output, "HSD"), output$hsd)
})
test_that("list elements accessible via $ and [[", {
output <- multiple_comparisons(dat.aov, classify = "Species")
# Test $ access
expect_s3_class(output$predictions, "data.frame")
expect_true(is.matrix(output$pairwise_pvalues))
expect_type(output$hsd, "double")
expect_type(output$sig_level, "double")
# Test [[ access
expect_identical(output$predictions, output[[1]])
expect_identical(output$pairwise_pvalues, output[[2]])
expect_identical(output$hsd, output[[3]])
expect_identical(output$sig_level, output[[4]])
})
test_that("p-value matrix with different interval types", {
# All interval types should produce the same p-value matrix
output_ci <- multiple_comparisons(dat.aov, classify = "Species", int.type = "ci")
output_tukey <- multiple_comparisons(dat.aov, classify = "Species", int.type = "tukey")
output_1se <- multiple_comparisons(dat.aov, classify = "Species", int.type = "1se")
# P-values should be identical regardless of interval type
expect_equal(output_ci$pairwise_pvalues, output_tukey$pairwise_pvalues)
expect_equal(output_ci$pairwise_pvalues, output_1se$pairwise_pvalues)
})
test_that("p-value matrix with transformations", {
dat.aov.log <- aov(log(Petal.Width) ~ Species, data = iris)
output <- multiple_comparisons(dat.aov.log, classify = "Species",
trans = "log", offset = 0)
# Check p-value matrix exists and has correct properties
expect_true("pairwise_pvalues" %in% names(output))
expect_true(is.matrix(output$pairwise_pvalues))
expect_equal(nrow(output$pairwise_pvalues), 3)
expect_true(isSymmetric(output$pairwise_pvalues))
expect_equal(diag(output$pairwise_pvalues), rep(1, 3), ignore_attr = TRUE)
})
# ============================================================================
# ORIGINAL TESTS (Updated to work with new structure)
# ============================================================================
test_that("mct produces output", {
tmp <- withr::local_tempdir()
withr::with_dir(tmp, {
withr::local_file("Rplots.pdf")
output <- multiple_comparisons(dat.aov, classify = "Species", plot = TRUE)
while (grDevices::dev.cur() > 1) grDevices::dev.off()
expect_equal(output$predictions$predicted.value, c(0.25, 1.33, 2.03), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct output", autoplot(output))
})
})
test_that("mct ylab handles call/language labels", {
pp <- data.frame(
trt = factor(c("A", "B")),
predicted.value = c(1, 2),
std.error = c(0.1, 0.1),
Df = c(10, 10),
ci = c(0.2, 0.2),
low = c(0.8, 1.8),
up = c(1.2, 2.2),
groups = c("a", "b")
)
# Note: This test uses internal function, may need adjustment
# based on how add_attributes is updated
out <- biometryassist:::add_attributes(pp, ylab = quote(sqrt(response)),
crit_val = matrix(0, nrow = 2, ncol = 2),
aliased_names = NULL)
expect_identical(attr(out, "ylab"), quote(sqrt(response)))
})
test_that("add_attributes stores aliased and matrix HSD attributes", {
pp <- data.frame(
trt = factor(c("A", "B")),
predicted.value = c(1, 2),
std.error = c(0.1, 0.1),
df = c(10, 10),
ci = c(0.2, 0.2),
low = c(0.8, 1.8),
up = c(1.2, 2.2),
groups = c("a", "b")
)
# Non-constant matrix ensures the var() check takes the matrix branch.
crit_val <- matrix(c(0, 1, 2, 3), nrow = 2, ncol = 2)
out <- biometryassist:::add_attributes(
pp,
ylab = quote(log(Petal.Width)),
crit_val = crit_val,
aliased_names = "B",
trans = "log"
)
expect_identical(attr(out, "ylab"), "Petal.Width")
expect_identical(attr(out, "aliased"), "B")
expect_identical(attr(out, "HSD"), crit_val)
})
test_that("mct transformation: log", {
dat.aov.log <- aov(log(Petal.Width) ~ Species, data = iris)
output.log <- multiple_comparisons(dat.aov.log, classify = "Species", trans = "log", offset = 0)
output.log2 <- multiple_comparisons(dat.aov.log, classify = "Species", trans = "log", offset = 0, int.type = "1se")
output.log3 <- multiple_comparisons(dat.aov.log, classify = "Species", trans = "log", offset = 0, int.type = "2se")
expect_identical(attr(output.log, "ylab"), "Petal.Width")
expect_equal(output.log$predictions$predicted.value, c(-1.48, 0.27, 0.70), tolerance = 5e-2)
expect_equal(output.log2$predictions$low, c(0.22, 1.26, 1.94), tolerance = 5e-2)
expect_equal(output.log3$predictions$up, c(0.25, 1.41, 2.17), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct log output", autoplot(output.log))
})
test_that("mct transformation: sqrt", {
dat.aov.sqrt <- aov(sqrt(Petal.Width) ~ Species, data = iris)
output.sqrt <- multiple_comparisons(dat.aov.sqrt, classify = "Species", trans = "sqrt", offset = 0)
output.sqrt2 <- multiple_comparisons(dat.aov.sqrt, classify = "Species", trans = "sqrt", offset = 0, int.type = "1se")
output.sqrt3 <- multiple_comparisons(dat.aov.sqrt, classify = "Species", trans = "sqrt", offset = 0, int.type = "2se")
expect_identical(attr(output.sqrt, "ylab"), "Petal.Width")
expect_equal(output.sqrt$predictions$predicted.value, c(0.49, 1.15, 1.42), tolerance = 5e-2)
expect_equal(output.sqrt2$predictions$low, c(0.23, 1.29, 1.98), tolerance = 5e-2)
expect_equal(output.sqrt3$predictions$up, c(0.27, 1.38, 2.09), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct sqrt output", autoplot(output.sqrt))
})
test_that("mct transformation: logit", {
dat.aov.logit <- aov(logit(1/Petal.Width) ~ Species, data = iris)
expect_warning(
output.logit <- multiple_comparisons(dat.aov.logit, classify = "Species", trans = "logit", offset = 0),
"Some standard errors are very small and would round to zero with 2 decimal places"
)
expect_warning(
output.logit2 <- multiple_comparisons(dat.aov.logit, classify = "Species", trans = "logit", offset = 0, int.type = "1se"),
"Some standard errors are very small and would round to zero with 2 decimal places"
)
expect_warning(
output.logit3 <- multiple_comparisons(dat.aov.logit, classify = "Species", trans = "logit", offset = 0, int.type = "2se"),
"Some standard errors are very small and would round to zero with 2 decimal places"
)
expect_identical(attr(output.logit, "ylab"), "1/Petal.Width")
expect_equal(output.logit$predictions$predicted.value, c(-5.30, -4.87, -3.07), tolerance = 5e-2)
expect_equal(output.logit2$predictions$low, c(0.00, 0.01, 0.04), tolerance = 5e-2)
expect_equal(output.logit3$predictions$up, c(0.01, 0.01, 0.05), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct logit output", autoplot(output.logit))
})
test_that("mct transformation: inverse", {
dat.aov.inverse <- aov((1/Petal.Width) ~ Species, data = iris)
output.inverse <- multiple_comparisons(dat.aov.inverse, classify = "Species", trans = "inverse", offset = 0)
output.inverse2 <- multiple_comparisons(dat.aov.inverse, classify = "Species", trans = "inverse", offset = 0, int.type = "1se")
output.inverse3 <- multiple_comparisons(dat.aov.inverse, classify = "Species", trans = "inverse", offset = 0, int.type = "2se")
expect_identical(attr(output.inverse, "ylab"), "Petal.Width")
expect_equal(output.inverse$predictions$predicted.value, c(0.50, 0.77, 4.79), tolerance = 5e-2)
expect_equal(output.inverse2$predictions$up, c(3.01, 1.66, 0.22), tolerance = 5e-2)
expect_equal(output.inverse3$predictions$low, c(1.20, 0.90, 0.20), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct inverse output", autoplot(output.inverse))
})
test_that("mct transformation: power", {
iris_new <- iris
iris_new$Petal.Width <- (iris_new$Petal.Width+1)^3
dat.aov.power <- aov(Petal.Width ~ Species, data = iris_new)
output.power <- multiple_comparisons(dat.aov.power, classify = "Species", trans = "power", offset = 1, power = 3)
output.power2 <- multiple_comparisons(dat.aov.power, classify = "Species", trans = "power", offset = 1, power = 3, int.type = "1se")
output.power3 <- multiple_comparisons(dat.aov.power, classify = "Species", trans = "power", offset = 1, power = 3, int.type = "2se")
expect_identical(attr(output.power, "ylab"), "Petal.Width")
expect_equal(output.power$predictions$predicted.value, c(1.98, 12.85, 28.38), tolerance = 5e-2)
expect_equal(output.power2$predictions$low, c(0.09, 1.30, 2.03), tolerance = 5e-2)
expect_equal(output.power3$predictions$up, c(0.49, 1.42, 2.10), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct power output", autoplot(output.power))
})
test_that("mct transformation: arcsin", {
iris_arc <- iris
iris_arc$PW <- iris_arc$Petal.Width / max(iris_arc$Petal.Width)
dat.aov.arcsin <- aov(asin(sqrt(PW)) ~ Species, data = iris_arc)
expect_warning(output.arcsin <- multiple_comparisons(dat.aov.arcsin,
classify = "Species",
trans = "arcsin", offset = 0),
"There are unevaluated constants in the response formula")
expect_identical(attr(output.arcsin, "ylab"), "PW")
expect_true("PredictedValue" %in% names(output.arcsin$predictions))
expect_true(all(output.arcsin$predictions$PredictedValue >= 0 & output.arcsin$predictions$PredictedValue <= 1))
expected_pw_means <- tapply(iris_arc$PW, iris_arc$Species, mean)
expect_equal(output.arcsin$predictions$PredictedValue,
as.numeric(expected_pw_means[as.character(output.arcsin$predictions$Species)]),
tolerance = 5e-2)
})
test_that("apply_transformation warns when offset is missing", {
pp <- data.frame(
predicted.value = c(0),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out <- biometryassist:::apply_transformation(pp, trans = "log", offset = NULL, power = NULL),
"Offset value assumed to be 0\\. Change with `offset` argument\\."
)
expect_true(all(c("PredictedValue", "ApproxSE", "low", "up") %in% names(out)))
})
test_that("multiple_comparisons warns when offset is omitted", {
dat.aov <- aov(log(Petal.Width) ~ Species, data = iris)
expect_warning(
multiple_comparisons(dat.aov, classify = "Species", trans = "log"),
"Offset value assumed to be 0\\. Change with `offset` argument\\."
)
})
test_that("apply_transformation warns for invalid back-transformed values", {
# sqrt: negative value after offset removal
pp.sqrt <- data.frame(
predicted.value = c(0.1),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out.sqrt <- biometryassist:::apply_transformation(pp.sqrt, trans = "sqrt", offset = 1, power = NULL),
"Square root back-transformation produced negative values\\. Check offset parameter\\."
)
expect_true(out.sqrt$PredictedValue < 0)
# log: non-positive value after offset removal
pp.log <- data.frame(
predicted.value = c(0),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out.log <- biometryassist:::apply_transformation(pp.log, trans = "log", offset = 1, power = NULL),
"Log back-transformation produced non-positive values\\. Check offset parameter\\."
)
expect_true(out.log$PredictedValue <= 0)
# logit: force exact boundary value with -Inf
pp.logit <- data.frame(
predicted.value = c(-Inf),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out.logit <- biometryassist:::apply_transformation(pp.logit, trans = "logit", offset = 0, power = NULL),
"Logit back-transformation produced values outside \\(0,1\\)"
)
expect_true(out.logit$PredictedValue <= 0 || out.logit$PredictedValue >= 1)
})
test_that("apply_transformation warns for inverse edge cases", {
pp.inv <- data.frame(
predicted.value = c(0.1),
std.error = c(0.1),
ci = c(0.2)
)
warnings <- character()
out <- withCallingHandlers(
biometryassist:::apply_transformation(pp.inv, trans = "inverse", offset = 0, power = NULL),
warning = function(w) {
warnings <<- c(warnings, conditionMessage(w))
invokeRestart("muffleWarning")
}
)
expect_true(any(grepl("Inverse transformation: confidence interval crosses zero", warnings, fixed = TRUE)))
expect_true("PredictedValue" %in% names(out))
expect_true(out$low <= out$up)
})
test_that("apply_transformation warns for inverse near-zero predicted values", {
pp.inv <- data.frame(
predicted.value = c(1e-20),
std.error = c(0.1),
ci = c(1e-25)
)
expect_warning(
out <- biometryassist:::apply_transformation(pp.inv, trans = "inverse", offset = 0, power = NULL),
"Inverse transformation: predicted values very close to zero detected\\."
)
expect_true("PredictedValue" %in% names(out))
})
test_that("apply_transformation power validation and warnings", {
pp <- data.frame(
predicted.value = c(1),
std.error = c(0.1),
ci = c(0.2)
)
expect_error(
biometryassist:::apply_transformation(pp, trans = "power", offset = 0, power = NULL),
"Power transformation requires a non-zero numeric 'power' argument\\."
)
expect_warning(
out <- biometryassist:::apply_transformation(pp, trans = "power", offset = 1, power = -1),
"Power back-transformation with negative power produced values near zero\\."
)
expect_true("PredictedValue" %in% names(out))
})
test_that("apply_transformation arcsin warning and bounds", {
pp <- data.frame(
predicted.value = c(pi),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out <- biometryassist:::apply_transformation(pp, trans = "arcsin", offset = 0, power = NULL),
"Arcsin transformation: some predicted values outside \\[-pi/2, pi/2\\]\\."
)
expect_true("PredictedValue" %in% names(out))
expect_true(out$PredictedValue >= 0 && out$PredictedValue <= 1)
})
test_that("apply_transformation arcsin warns when back-transformation is outside [0,1]", {
# This branch is numerically very hard to reach with real sin() output because sin(x)^2
# should be in [0,1]. Here we temporarily override `sin()` and `sqrt()` in the
# apply_transformation() function environment to force an out-of-bounds value.
fn2 <- biometryassist:::apply_transformation
fn2_env <- new.env(parent = environment(fn2))
fn2_env$sin <- function(x) rep(2, length(x))
fn2_env$sqrt <- function(x) rep(0, length(x))
environment(fn2) <- fn2_env
pp <- data.frame(
predicted.value = c(0),
std.error = c(0.1),
ci = c(0.2)
)
expect_warning(
out <- fn2(pp, trans = "arcsin", offset = 0, power = NULL),
"Arcsin back-transformation produced values outside \\[0,1\\]\\. This may indicate numerical issues\\."
)
expect_true("PredictedValue" %in% names(out))
expect_true(out$PredictedValue > 1)
})
test_that("apply_transformation errors on invalid trans", {
pp <- data.frame(
predicted.value = c(0),
std.error = c(0.1),
ci = c(0.2)
)
expect_error(
biometryassist:::apply_transformation(pp, trans = "not-a-transformation", offset = 0, power = NULL),
"Invalid trans value\\. Must be one of: 'sqrt', 'log', 'logit', 'power', 'inverse', 'arcsin'\\.",
fixed = FALSE
)
})
test_that("ordering output works", {
output1 <- multiple_comparisons(dat.aov, classify = "Species", descending = FALSE)
output2 <- multiple_comparisons(dat.aov, classify = "Species", descending = TRUE)
expect_equal(output1$predictions$predicted.value, c(0.25, 1.33, 2.03), tolerance = 5e-2)
expect_equal(output2$predictions$predicted.value, c(2.03, 1.33, 0.25), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct ascending order", autoplot(output1))
vdiffr::expect_doppelganger("mct descending output", autoplot(output2))
})
test_that("different interval types work", {
output1 <- multiple_comparisons(dat.aov, classify = "Species", int.type = "1se")
output2 <- multiple_comparisons(dat.aov, classify = "Species", int.type = "2se")
expect_equal(output1$predictions$low, c(0.22, 1.30, 2.00), tolerance = 5e-2)
expect_equal(output1$predictions$up, c(0.28, 1.36, 2.06), tolerance = 5e-2)
expect_equal(output2$predictions$low, c(0.19, 1.27, 1.97), tolerance = 5e-2)
expect_equal(output2$predictions$up, c(0.31, 1.39, 2.09), tolerance = 5e-2)
vdiffr::expect_doppelganger("mct output 1se", autoplot(output1))
vdiffr::expect_doppelganger("mct output 2se", autoplot(output2))
})
test_that("Testing asreml predictions", {
skip_if_not_installed("Matrix")
load(test_path("data", "asreml_model.Rdata"), .GlobalEnv)
expect_warning(output <- multiple_comparisons(model.asr,
classify = "Nitrogen",
pred.obj = pred.asr,
dendf = dendf),
"Argument `pred\\.obj` has been deprecated and will be removed in a future version\\. Predictions are now performed internally in the function\\.")
expect_equal(output$predictions$predicted.value,
c(77.76, 100.15, 114.41, 123.23),
tolerance = 5e-2)
expect_snapshot_output(output)
vdiffr::expect_doppelganger("asreml predictions", autoplot(output))
})
test_that("save produces output", {
withr::local_file("pred_vals.csv")
output <- multiple_comparisons(dat.aov, classify = "Species", save = TRUE, savename = "pred_vals")
expect_snapshot_output(output)
expect_csv_matches_df(output$predictions, "pred_vals.csv")
})
test_that("Interaction terms work", {
load(test_path("data", "asreml_model.Rdata"), .GlobalEnv)
skip_if_not_installed("asreml")
quiet(library(asreml))
output <- multiple_comparisons(model.asr, classify = "Nitrogen:Variety", pvals = T)
expect_equal(output$predictions$predicted.value,
c(70.85, 76.58, 85.86, 92.22, 99.91, 108.32, 113.1, 113.5, 116.63, 118.4, 123.75, 127.53),
tolerance = 5e-2)
vdiffr::expect_doppelganger("Interactions work", autoplot(output))
})
test_that("order argument is deprecated", {
# dat.aov <- aov(Petal.Width ~ Species, data = iris)
expect_warning(multiple_comparisons(dat.aov, classify = "Species", order = "xyz"),
"Argument `order` has been deprecated and will be removed in a future version. Please use `descending` instead.")
})
test_that("dashes are handled", {
iris2 <- iris
# Replace 'gin' in setosa with '-'
iris2$Species <- as.factor(gsub("to", "-", iris2$Species))
dat.aov2 <- aov(Petal.Width ~ Species, data = iris2)
output2 <- suppressWarnings(multiple_comparisons(dat.aov2, classify = "Species"))
expect_warning(multiple_comparisons(dat.aov2, classify = "Species"),
"The treatment level se-sa contained '-', which has been replaced in the final output with '_'")
expect_equal(output2$predictions$predicted.value, c(0.25, 1.33, 2.03), tolerance = 5e-2)
# Replace 'gin' in virginica with '-' as well
iris2$Species <- as.factor(gsub("gin", "-", iris2$Species))
dat.aov2 <- aov(Petal.Width ~ Species, data = iris2)
expect_warning(multiple_comparisons(dat.aov2, classify = "Species"),
"The treatment levels se-sa, vir-ica contained '-', which has been replaced in the final output with '_'")
expect_equal(output2$predictions$predicted.value, c(0.25, 1.33, 2.03), tolerance = 5e-2)
# skip_if(interactive())
vdiffr::expect_doppelganger("mct dashes output", autoplot(output2))
})
test_that("mct removes aliased treatments in aov", {
CO_2 <- CO2
CO_2$uptake[CO_2$Type=="Quebec" & CO_2$Treatment=="nonchilled"] <- NA
model <- aov(uptake~Type+Treatment+Type:Treatment, data = CO_2)
expect_warning(output1 <- multiple_comparisons(model, classify = "Type:Treatment"),
"A level of Type\\:Treatment is aliased\\. It has been removed from predicted output\\.\n Aliased level is\\: Quebec:nonchilled\\.\n This level is saved as an attribute of the output object\\.")
expect_snapshot_output(output1$predictions$predicted.value)
# skip_if(interactive())
vdiffr::expect_doppelganger("aov aliased output", autoplot(output1))
})
test_that("mct handles aliased results in asreml with a warning", {
skip_if_not_installed("asreml")
quiet(library(asreml))
load(test_path("data", "asreml_model.Rdata"), envir = .GlobalEnv)
load(test_path("data", "oats_data_missing.Rdata"), envir = .GlobalEnv)
expect_warning(
output <- multiple_comparisons(model.asr, classify = "Nitrogen:Variety"),
"Aliased level is: 0\\.2_cwt:Golden_rain\\."
)
expect_snapshot_output(output)
load(test_path("data", "oats_data_missing2.Rdata"), envir = .GlobalEnv)
expect_warning(
output <- multiple_comparisons(model2.asr, classify = "Nitrogen:Variety"),
"Some levels of Nitrogen:Variety are aliased\\. They have been removed from predicted output\\."
)
expect_snapshot_output(output)
expect_warning(multiple_comparisons(model2.asr, classify = "Nitrogen:Variety"),
"Aliased levels are: 0\\.2_cwt:Golden_rain, 0\\.2_cwt:Victory\\.")
})
test_that("Invalid classify argument causes an error", {
dat.aov <- aov(Petal.Width ~ Species, data = iris)
expect_error(multiple_comparisons(dat.aov, classify = "ABC"),
"ABC is not a term in the model\\. Please check model specification\\.")
expect_error(multiple_comparisons(model.asr, classify = "ABC"),
"ABC is not a term in the model\\. Please check model specification\\.")
})
test_that("Significance values that are too high give a warning or error", {
# dat.aov <- aov(Petal.Width ~ Species, data = iris)
expect_warning(multiple_comparisons(dat.aov, classify = "Species", sig = 0.95),
"Significance level given by `sig` is high. Perhaps you meant 0.05?")
expect_error(multiple_comparisons(dat.aov, classify = "Species", sig = 5),
"Significance level given by `sig` is high. Perhaps you meant 0.05?")
expect_error(multiple_comparisons(dat.aov, classify = "Species", sig = 95),
"Significance level given by `sig` is high. Perhaps you meant 0.05?")
})
test_that("Use of pred argument gives warning", {
# dat.aov <- aov(Petal.Width ~ Species, data = iris)
expect_warning(multiple_comparisons(dat.aov, classify = "Species", pred = "Species"),
"Argument `pred` has been deprecated and will be removed in a future version. Please use `classify` instead.")
})
test_that("Invalid column name causes an error", {
dat <- design("crd", LETTERS[1:4], 4, nrow = 4, ncols = 4, quiet = TRUE)$design
names(dat)[5] <- "groups"
dat.aov <- aov(rnorm(16, 10)~groups, data = dat)
expect_error(multiple_comparisons(dat.aov, classify = "groups"),
"Invalid column name. Please change the name of column\\(s\\): groups")
})
test_that("Including pred.obj object causes warning", {
skip_if_not_installed("asreml")
quiet(library(asreml))
load(test_path("data", "asreml_model.Rdata"), envir = .GlobalEnv)
expect_warning(multiple_comparisons(model.asr, pred.obj = pred.asr, classify = "Nitrogen"),
"Argument \\`pred.obj\\` has been deprecated and will be removed in a future version\\. Predictions are now performed internally in the function\\.")
})
test_that("Providing a random term in classify produces an error.", {
skip_if_not_installed("asreml")
load(test_path("data", "oats_data_missing2.Rdata"), envir = .GlobalEnv)
expect_error(multiple_comparisons(model2.asr, classify = "Blocks"),
"All predicted values are aliased\\. Perhaps you need the `present` argument\\?")
})
test_that("lme4 model works", {
skip_if_not_installed("lme4")
quiet(library(lme4))
dat.lmer <- lmer(yield ~ Nitrogen*Variety + (1|Blocks), data = dat)
output <- multiple_comparisons(dat.lmer, classify = "Nitrogen")
expect_equal(output$predictions$std.error, rep(7.39, 4), tolerance = 5e-2)
expect_equal(min(output$predictions$predicted.value), 79.39, tolerance = 5e-2)
expect_equal(max(output$predictions$predicted.value), 123.39, tolerance = 5e-2)
expect_equal(output$predictions$predicted.value, c(79.39, 98.89, 114.22, 123.39), tolerance = 5e-2)
vdiffr::expect_doppelganger("lme4 output", autoplot(output))
})
test_that("3 way interaction works", {
des <- design(type = "crossed:crd", treatments = c(3, 3, 3),
reps = 3, nrows = 9, ncols = 9, seed = 42, quiet = TRUE)
des$design$response <- rnorm(81, 100)
des$design$A <- factor(des$design$A)
des$design$B <- factor(des$design$B)
des$design$C <- factor(des$design$C)
dat.aov <- aov(response~A*B*C, data = des$design)
output <- multiple_comparisons(dat.aov, classify = "A:B:C")
expect_snapshot_output(output$predictions$predicted.value)
expect_equal(output$predictions$std.error,
rep(0.63, 27))
# skip_if(interactive())
vdiffr::expect_doppelganger("3 way interaction", autoplot(output), variant = ggplot2_variant())
})
test_that("plots are produced when requested", {
withr::local_seed(123)
des <- design(type = "crossed:crd", treatments = c(3, 3, 3),
reps = 3, nrows = 9, ncols = 9, seed = 42, quiet = TRUE)
des$design$response <- rnorm(81, 100)
des$design$A <- factor(des$design$A)
des$design$B <- factor(des$design$B)
des$design$C <- factor(des$design$C)
dat.aov <- aov(response~A*B*C, data = des$design)
tmp <- withr::local_tempdir()
withr::with_dir(tmp, {
withr::local_file("Rplots.pdf")
expect_snapshot_output(
output <- multiple_comparisons(dat.aov, classify = "A:B:C", plot = TRUE)
)
while (grDevices::dev.cur() > 1) grDevices::dev.off()
expect_s3_class(output, "mct")
expect_equal(nrow(output$predictions), 27)
expect_equal(output$predictions$std.error, rep(0.63, 27))
skip_if(interactive())
vdiffr::expect_doppelganger(
"3 way interaction internal",
function() {
invisible(multiple_comparisons(dat.aov, classify = "A:B:C", plot = TRUE))
},
variant = ggplot2_variant()
)
while (grDevices::dev.cur() > 1) grDevices::dev.off()
})
})
test_that("nlme model produces an error", {
skip_if_not_installed("nlme")
suppressPackageStartupMessages(library(nlme))
load(test_path("data", "oats_data.Rdata"), envir = .GlobalEnv)
dat.lme <- lme(yield ~ Nitrogen*Variety, random = ~1|Blocks, data = dat)
output <- multiple_comparisons(dat.lme, classify = "Nitrogen")
expect_equal(output$predictions$std.error, rep(7.39, 4), tolerance = 5e-2)
expect_equal(min(output$predictions$predicted.value), 79.39, tolerance = 5e-2)
expect_equal(max(output$predictions$predicted.value), 123.39, tolerance = 5e-2)
expect_equal(output$predictions$predicted.value, c(79.39, 98.89, 114.22, 123.39), tolerance = 5e-2)
vdiffr::expect_doppelganger("nlme output", autoplot(output))
})
test_that("invalid model types give a clear error", {
# Use an unsupported model type that still has a `formula()` method so that
# the error comes from `get_predictions.default()` (not from validate_inputs()).
dat <- data.frame(x = 1:10, y = 1:10)
m <- stats::nls(density ~ SSlogis(log(conc), Asym, xmid, scal), data = subset(DNase, Run == 1))
expect_error(
multiple_comparisons(m, classify = "x"),
"model\\.obj must be a linear \\(mixed\\) model object\\.",
fixed = FALSE
)
})
test_that("multiple_comparisons output has a class of 'mct'", {
output <- multiple_comparisons(dat.aov, classify = "Species")
expect_s3_class(output, "mct")
})
test_that("Setting groups to FALSE disables letter groups", {
output <- multiple_comparisons(dat.aov, classify = "Species")
expect_true("groups" %in% colnames(output$predictions))
expect_equal(output$predictions$groups, c("a", "b", "c"))
output <- multiple_comparisons(dat.aov, classify = "Species", groups = FALSE)
expect_false("groups" %in% colnames(output$predictions))
output <- multiple_comparisons(dat.aov, classify = "Species", letters = FALSE)
expect_false("groups" %in% colnames(output$predictions))
vdiffr::expect_doppelganger("No letter groups",
autoplot(output))
})
test_that("Check for letters as an alias of groups", {
expect_warning(output <- multiple_comparisons(dat.aov, classify = "Species",
groups = FALSE, letters = TRUE),
"Both 'groups' and 'letters' provided\\. Using 'groups'\\.")
expect_false("groups" %in% colnames(output$predictions))
})
test_that("autoplot supports legacy mct data.frame objects", {
# Old versions of biometryassist used an `mct` object that was itself a data.frame.
# This test covers the backward-compatibility branch in autoplot.mct().
legacy <- data.frame(
Species = factor(c("setosa", "versicolor", "virginica")),
predicted.value = c(0.25, 1.33, 2.03),
std.error = c(0.02, 0.02, 0.02),
ci = c(0.05, 0.05, 0.05),
low = c(0.20, 1.28, 1.98),
up = c(0.30, 1.38, 2.08),
groups = c("a", "b", "c")
)
class(legacy) <- c("mct", class(legacy))
attr(legacy, "ylab") <- "Petal.Width"
p <- autoplot(legacy)
expect_s3_class(p, "ggplot")
})
test_that("autoplot can rotate axis and labels independently", {
output <- multiple_comparisons(dat.aov, classify = "Species")
vdiffr::expect_doppelganger("label rotation",
autoplot(output, label_rotation = 90))
vdiffr::expect_doppelganger("axis rotation",
autoplot(output, axis_rotation = 90))
vdiffr::expect_doppelganger("axis rotation -90",
autoplot(output, axis_rotation = -90))
vdiffr::expect_doppelganger("axis and label rotation",
autoplot(output, axis_rotation = 45, label_rotation = 90))
vdiffr::expect_doppelganger("rotation and axis rotation",
autoplot(output, rotation = 45, axis_rotation = 90))
vdiffr::expect_doppelganger("rotation and label rotation",
autoplot(output, rotation = 45, label_rotation = 90))
})
test_that("Autoplot can output column graphs", {
output <- multiple_comparisons(dat.aov, classify = "Species")
p1 <- autoplot(output, type = "column", label_height = 1)
p2 <- autoplot(output, type = "col", label_height = 1)
expect_in("GeomCol", class(p1$layers[[1]]$geom))
expect_in("GeomCol", class(p2$layers[[1]]$geom))
expect_true(equivalent_ggplot2(p1, p2))
vdiffr::expect_doppelganger("autoplot column", p1)
})
test_that("A warning is printed if a transformation is detected with no trans argument provided", {
dat.aov.log <- aov(log(Petal.Width) ~ Species, data = iris)
dat.aov.sqrt <- aov(sqrt(Petal.Width) ~ Species, data = iris)
dat.aov.logit <- aov(logit(1/Petal.Width) ~ Species, data = iris)
dat.aov.inverse <- aov((1/Petal.Width) ~ Species, data = iris)
dat.aov.power <- aov(Petal.Width^3 ~ Species, data = iris)
expect_warning(multiple_comparisons(dat.aov.log, classify = "Species"),
"The response variable appears to be transformed in the model formula: log\\(Petal\\.Width\\)\\.
Please specify the 'trans' argument if you want back-transformed predictions\\.")
expect_warning(multiple_comparisons(dat.aov.sqrt, classify = "Species"),
"The response variable appears to be transformed in the model formula: sqrt\\(Petal\\.Width\\)\\.
Please specify the 'trans' argument if you want back-transformed predictions\\.")
expect_warning(multiple_comparisons(dat.aov.logit, classify = "Species"),
"The response variable appears to be transformed in the model formula: logit\\(1/Petal\\.Width\\)\\.
Please specify the 'trans' argument if you want back-transformed predictions\\.")
expect_warning(multiple_comparisons(dat.aov.inverse, classify = "Species"),
"The response variable appears to be transformed in the model formula: \\(1/Petal\\.Width\\)\\.
Please specify the 'trans' argument if you want back-transformed predictions\\.")
expect_warning(multiple_comparisons(dat.aov.power, classify = "Species"),
"The response variable appears to be transformed in the model formula: Petal\\.Width\\^3\\.
Please specify the 'trans' argument if you want back-transformed predictions\\.")
})
# Test aliased output prints
test_that("print.mct with no aliased attribute", {
dat.aov <- aov(Petal.Width ~ Species, data = iris)
output <- multiple_comparisons(dat.aov, classify = "Species", plot = FALSE)
# Manually set aliased for testing (in new structure)
output$aliased <- "ABC"
attr(output, "aliased") <- "ABC"
expect_true("aliased" %in% names(output))
expect_length(output$aliased, 1)
expect_output(print(output),
"Aliased level is: ABC")
output$aliased <- c("ABC", "DEF")
attr(output, "aliased") <- c("ABC", "DEF")
expect_length(output$aliased, 2)
expect_true("aliased" %in% names(output))
expect_output(print(output),
"Aliased levels are: ABC and DEF")
output$aliased <- c("ABC", "DEF", "GHI")
attr(output, "aliased") <- c("ABC", "DEF", "GHI")
expect_length(output$aliased, 3)
expect_true("aliased" %in% names(output))
expect_output(print(output),
"Aliased levels are: ABC, DEF and GHI")
})
test_that("Standard error rounding preserves error bars", {
# Create data with very small standard errors
set.seed(123)
# Create a mock model that would produce very small standard errors
# We'll use a simple approach with very precise data
precise_data <- data.frame(
treatment = factor(rep(c("A", "B", "C"), each = 100)),
response = c(rep(1.000001, 100), rep(1.000002, 100), rep(1.000003, 100)) +
rnorm(300, 0, 0.0000001) # Very small error
)
dat.aov <- aov(response ~ treatment, data = precise_data)
# Test with default decimals (2) - should trigger warning
expect_warning(
output <- multiple_comparisons(dat.aov, classify = "treatment", decimals = 2),
"Some standard errors are very small and would round to zero with 2 decimal places"
)
# Check that standard errors are preserved (not rounded to 0)
expect_true(all(output$predictions$std.error > 0))
expect_false(any(output$predictions$std.error == 0))
# Check that other columns are still rounded to 2 decimal places
expect_true(all(nchar(sub(".*\\.", "", as.character(output$predictions$predicted.value))) <= 2))
})
test_that("Standard error rounding works with transformed data", {
# Create data that will have small standard errors on the transformed scale
set.seed(456)
# Use data that's already on log scale with very small differences
transform_data <- data.frame(
treatment = factor(rep(c("A", "B", "C"), each = 100)),
# Create log-scale response with tiny differences and very small error
log_response = c(rep(-0.0001, 100), rep(0.0000, 100), rep(0.0001, 100)) +
rnorm(300, 0, 0.000001) # Very small error on log scale
)
# Apply log transformation - the model is on log scale, transform back to original
dat.aov <- aov(log_response ~ treatment, data = transform_data)
# Test with transformation - should handle both std.error and ApproxSE
expect_warning(
output <- multiple_comparisons(dat.aov, classify = "treatment",
trans = "log", offset = 0, decimals = 3),
"Some standard errors are very small"
)
# Check that both standard error columns are preserved
expect_true(all(output$predictions$std.error > 0))
expect_true(all(output$predictions$ApproxSE > 0))
expect_false(any(output$predictions$std.error == 0))
expect_false(any(output$predictions$ApproxSE == 0))
})
test_that("Normal rounding works when standard errors are not too small", {
# Use the standard iris data which has reasonable standard errors
dat.aov <- aov(Petal.Width ~ Species, data = iris)
# Should not trigger warning with normal data
expect_no_warning(
output <- multiple_comparisons(dat.aov, classify = "Species", decimals = 2)
)
# Check that all numeric columns are properly rounded
expect_true(all(nchar(sub(".*\\.", "", as.character(output$predictions$predicted.value))) <= 2))
expect_true(all(nchar(sub(".*\\.", "", as.character(output$predictions$std.error))) <= 2))
})
test_that("Standard error rounding works with different decimal settings", {
# Create data with moderately small standard errors
set.seed(789)
moderate_data <- data.frame(
treatment = factor(rep(c("A", "B"), each = 20)),
response = c(rep(1.001, 20), rep(1.002, 20)) + rnorm(40, 0, 0.001)
)
dat.aov <- aov(response ~ treatment, data = moderate_data)
# Test with decimals = 4 (should not trigger warning)
expect_no_warning(
output4 <- multiple_comparisons(dat.aov, classify = "treatment", decimals = 4)
)
# Test with decimals = 1 (might trigger warning depending on actual SE values)
expect_warning(
output1 <- multiple_comparisons(dat.aov, classify = "treatment", decimals = 1),
"Some standard errors are very small and would round to zero with 1 decimal places"
)
# Ensure standard errors are never exactly 0
expect_true(all(output1$predictions$std.error > 0))
expect_true(all(output4$predictions$std.error > 0))
})
test_that("ApproxSE column is also preserved during rounding", {
# Create data that will trigger the standard error preservation
set.seed(111)
# Create data with extremely small values to get tiny standard errors after log transformation
precise_data <- data.frame(
treatment = factor(rep(c("A", "B"), each = 100)),
# Use very small response values that will have tiny standard errors
response = c(rep(0.000001, 100), rep(0.000002, 100)) + rnorm(200, 0, 0.0000001)
)
# Use log transformation to create ApproxSE column
dat.aov <- aov(log(response) ~ treatment, data = precise_data)
# Should trigger warning and preserve both std.error and ApproxSE
expect_warning(
output <- multiple_comparisons(dat.aov, classify = "treatment",
trans = "log", offset = 0, decimals = 2),
"Some standard errors are very small"
)
# Both standard error columns should be preserved
expect_true(all(output$predictions$std.error > 0))
expect_true(all(output$predictions$ApproxSE > 0))
expect_false(any(output$predictions$std.error == 0))
expect_false(any(output$predictions$ApproxSE == 0))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.