9 Tests for selection and prediction functions
Tests for checkCutoff():
testthat::test_that("checkCutoff works", {
testthat::expect_null(checkCutoff(0))
testthat::expect_null(checkCutoff(0.2))
testthat::expect_null(checkCutoff(1))
testthat::expect_error(checkCutoff(-.2), "cutoff >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkCutoff(2), "cutoff <= 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkCutoff(".3"),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkCutoff(matrix(1:12, nrow=4, ncol=3)),
"length(cutoff) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkCutoff(numeric()),
"length(cutoff) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkCutoff(as.numeric(NA)),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
})## Test passed with 9 successes.Tests for checkWeighting():
testthat::test_that("checkWeighting works", {
testthat::expect_null(checkWeighting("sparse"))
testthat::expect_null(checkWeighting("simple_avg"))
testthat::expect_null(checkWeighting("weighted_avg"))
testthat::expect_error(checkWeighting(c("sparse", "simple_avg")),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkWeighting(NA), "!is.na(weighting) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkWeighting(1), "Weighting must be a character",
fixed=TRUE)
testthat::expect_error(checkWeighting("spasre"),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
})## Test passed with 7 successes.Tests for checkMinNumClusts():
testthat::test_that("checkMinNumClusts works", {
testthat::expect_null(checkMinNumClusts(1, 5, 4))
testthat::expect_null(checkMinNumClusts(6, 6, 6))
testthat::expect_null(checkMinNumClusts(3, 1932, 3))
# min_num_clusts = 0 is now allowed (empty threshold selection)
testthat::expect_null(checkMinNumClusts(0, 13, 7))
testthat::expect_error(checkMinNumClusts(c(2, 4), 5, 4),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkMinNumClusts("3", "1932", "3"),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMinNumClusts(NA, NA, NA),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMinNumClusts(as.numeric(NA), as.numeric(NA),
as.numeric(NA)),
"!is.na(min_num_clusts) is not TRUE", fixed=TRUE)
testthat::expect_error(checkMinNumClusts(-1, 13, 7),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkMinNumClusts(-1, 9, 8),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkMinNumClusts(6, 5, 5),
"min_num_clusts <= p is not TRUE", fixed=TRUE)
testthat::expect_error(checkMinNumClusts(6, 7, 5),
"min_num_clusts <= n_clusters is not TRUE", fixed=TRUE)
})## Test passed with 12 successes.Tests for checkMaxNumClusts():
testthat::test_that("checkMaxNumClusts works", {
testthat::expect_equal(checkMaxNumClusts(max_num_clusts=4, min_num_clusts=1,
p=5, n_clusters=4), 4)
testthat::expect_equal(checkMaxNumClusts(max_num_clusts=5, min_num_clusts=1,
p=5, n_clusters=4), 4)
testthat::expect_true(is.na(checkMaxNumClusts(max_num_clusts=NA,
min_num_clusts=3, p=5,
n_clusters=4)))
testthat::expect_error(checkMaxNumClusts(max_num_clusts="4", min_num_clusts=1,
p=5, n_clusters=4),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=3.2, min_num_clusts=2,
p=5, n_clusters=4),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=1, min_num_clusts=2,
p=5, n_clusters=4),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=c(3, 4),
min_num_clusts=2,
p=5, n_clusters=4),
"length(max_num_clusts) == 1 is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts="4",
min_num_clusts="2",
p="5", n_clusters="4"),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=-1, min_num_clusts=2,
p=5, n_clusters=4),
"max_num_clusts >= 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=6, min_num_clusts=2,
p=5, n_clusters=4),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
testthat::expect_error(checkMaxNumClusts(max_num_clusts=1, min_num_clusts=2,
p=5, n_clusters=4),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
})## Test passed with 11 successes.Test for checkSelectedClusters():
testthat::test_that("checkSelectedClusters works", {
testthat::expect_null(checkSelectedClusters(n_sel_clusts=5, min_num_clusts=1,
max_num_clusts=NA, max_sel_prop=.8))
testthat::expect_null(checkSelectedClusters(n_sel_clusts=5, min_num_clusts=2,
max_num_clusts=5, max_sel_prop=.3))
testthat::expect_null(checkSelectedClusters(n_sel_clusts=2, min_num_clusts=2,
max_num_clusts=5, max_sel_prop=.3))
testthat::expect_error(checkSelectedClusters(n_sel_clusts=0, min_num_clusts=2,
max_num_clusts=5,
max_sel_prop=.6),
"No clusters selected with this cutoff (try a cutoff below the maximum cluster selection proportion, 0.6)",
fixed=TRUE)
testthat::expect_warning(checkSelectedClusters(n_sel_clusts=1,
min_num_clusts=2,
max_num_clusts=5,
max_sel_prop=.6),
"Returning fewer than min_num_clusts = 2 clusters because decreasing the cutoff any further would require returning more than max_num_clusts = 5 clusters",
fixed=TRUE)
testthat::expect_warning(checkSelectedClusters(n_sel_clusts=6,
min_num_clusts=2,
max_num_clusts=5,
max_sel_prop=.6),
"Returning more than max_num_clusts = 5 clusters because increasing the cutoff any further would require returning 0 clusters",
fixed=TRUE)
})## Test passed with 6 successes.Tests for getClustWeights():
testthat::test_that("getClustWeights works", {
sel_props <- c(0.1, 0.3, 0.5, 0.7, 0.9)
# sparse
testthat::expect_identical(getClustWeights(cluster_i=c(3L, 4L, 5L),
weighting="sparse",
feat_sel_props=sel_props),
c(0, 0, 1))
# weighted_avg
cluster=c(1L, 3L, 5L)
true_weights <- sel_props[cluster]/sum(sel_props[cluster])
testthat::expect_identical(getClustWeights(cluster_i=cluster,
weighting="weighted_avg",
feat_sel_props=sel_props),
true_weights)
# simple_avg
testthat::expect_identical(getClustWeights(cluster_i=c(2L, 3L, 4L, 5L),
weighting="simple_avg",
feat_sel_props=sel_props),
rep(0.25, 4))
# (#105, L11) Zero-selection fallback: when every member of the cluster has
# selection proportion 0 (so sum(sel_props) == 0), both "sparse" and
# "weighted_avg" must fall back to equal weights rep(1/n, n) rather than
# dividing by zero.
zero_props <- c(0, 0, 0, 0.5, 0.8)
testthat::expect_identical(getClustWeights(cluster_i=c(1L, 2L, 3L),
weighting="sparse",
feat_sel_props=zero_props),
rep(1/3, 3))
testthat::expect_identical(getClustWeights(cluster_i=c(1L, 2L, 3L),
weighting="weighted_avg",
feat_sel_props=zero_props),
rep(1/3, 3))
# (#105, L11) Sparse tie-split: when two cluster members tie for the top
# selection proportion, "sparse" splits the weight equally between them (and
# gives 0 to the rest) rather than arbitrarily picking one.
tie_props <- c(0.9, 0.9, 0.3, 0.5, 0.8)
testthat::expect_identical(getClustWeights(cluster_i=c(1L, 2L, 3L),
weighting="sparse",
feat_sel_props=tie_props),
c(0.5, 0.5, 0))
})## Test passed with 6 successes.Tests for getAllClustWeights():
testthat::test_that("getAllClustWeights works", {
set.seed(1872)
x <- matrix(stats::rnorm(10*5), nrow=10, ncol=5)
y <- stats::rnorm(10)
clust_names <- letters[1:3]
good_clusters <- list(1:2, 3:4, 5)
names(good_clusters) <- clust_names
res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso,
sampling_type = "SS", B = 10, prop_feats_remove = 0, train_inds = integer(),
num_cores = 1L)
sel_props <- colMeans(res$feat_sel_mat)
sel_clusts <- list(1L:2L, 3L:4L)
names(sel_clusts) <- clust_names[1:2]
# sparse
true_weights <- list()
for(i in 1:2){
weights_i <- sel_props[sel_clusts[[i]]]/sum(sel_props[sel_clusts[[i]]])
true_weights[[i]] <- rep(0, length(weights_i))
true_weights[[i]][weights_i == max(weights_i)] <- 1
true_weights[[i]] <- true_weights[[i]]/sum(true_weights[[i]])
}
names(true_weights) <- clust_names[1:2]
testthat::expect_identical(getAllClustWeights(res,
colMeans(res$clus_sel_mat[, 1:2]),
"sparse"), true_weights)
# weighted_avg
true_weights <- list()
for(i in 1:2){
true_weights[[i]] <- sel_props[sel_clusts[[i]]]/sum(sel_props[unlist(sel_clusts[[i]])])
}
names(true_weights) <- clust_names[1:2]
testthat::expect_identical(getAllClustWeights(res,
colMeans(res$clus_sel_mat[, 1:2]),
"weighted_avg"), true_weights)
# simple_avg
true_weights <- list()
for(i in 1:2){
n_weights_i <- length(sel_clusts[[i]])
true_weights[[i]] <- rep(1/n_weights_i, n_weights_i)
}
names(true_weights) <- clust_names[1:2]
testthat::expect_identical(getAllClustWeights(res,
colMeans(res$clus_sel_mat[, 1:2]),
"simple_avg"), true_weights)
# Errors
# css_results not correct (error has quotation marks)
testthat::expect_error(getAllClustWeights(1:4, colMeans(res$clus_sel_mat[,
1:2]),
"simple_avg"))
bad_sel_clusts <- colMeans(res$clus_sel_mat[, 1:2])
names(bad_sel_clusts) <- c("apple", "banana")
testthat::expect_error(getAllClustWeights(res, bad_sel_clusts, "sparse"),
"all(names(sel_clusters) %in% names(clusters)) is not TRUE",
fixed=TRUE)
testthat::expect_error(getAllClustWeights(res, colMeans(res$clus_sel_mat[,
1:2]),
c("sparse", "simple_avg")),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(getAllClustWeights(res, colMeans(res$clus_sel_mat[,
1:2]),
NA),
"!is.na(weighting) is not TRUE", fixed=TRUE)
testthat::expect_error(getAllClustWeights(res, colMeans(res$clus_sel_mat[,
1:2]),
1),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(getAllClustWeights(res, colMeans(res$clus_sel_mat[,
1:2]),
"spasre"),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
})## Test passed with 9 successes.Tests for checkGetSelectedClustersOutput():
testthat::test_that("checkGetSelectedClustersOutput works", {
sel_clusts <- 0.1*(1:9)
names(sel_clusts) <- letters[1:9]
weights <- list()
for(i in 1:8){
weights[[i]] <- c(0.2, 0.3)
}
weights[[9]] <- 0.4
names(weights) <- letters[1:9]
sel_feats <- 10:26
names(sel_feats) <- LETTERS[10:26]
testthat::expect_null(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30))
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=letters[1:4],
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"is.numeric(selected_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=-sel_clusts,
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"all(selected_clusts >= 0) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=10*sel_clusts,
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"all(selected_clusts <= 1) is not TRUE",
fixed=TRUE)
# An empty selection is now allowed (min_num_clusts=0), so length 0 no longer
# trips a guard; an unnamed empty selected_clusts is still rejected (it fails
# the names check before the length check would matter).
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=numeric(),
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"!is.null(names(selected_clusts)) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=sel_feats,
weights=weights,
n_clusters=8, p=30),
"length(selected_clusts) <= n_clusters is not TRUE",
fixed=TRUE)
bad_clusts <- sel_clusts
names(bad_clusts) <- rep("a", length(bad_clusts))
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=bad_clusts,
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"length(names(selected_clusts)) == length(unique(names(selected_clusts))) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=unname(sel_clusts),
selected_feats=sel_feats,
weights=weights,
n_clusters=10, p=30),
"!is.null(names(selected_clusts)) is not TRUE",
fixed=TRUE)
bad_clusts <- sel_clusts
names(bad_clusts)[1] <- ""
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=bad_clusts,
selected_feats=sel_feats, weights=weights,
n_clusters=10, p=30),
"all(!is.na(names(selected_clusts)) & names(selected_clusts) != .... is not TRUE",
fixed=TRUE)
names(bad_clusts)[1] <- as.character(NA)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=bad_clusts,
selected_feats=sel_feats, weights=weights,
n_clusters=10, p=30),
"all(!is.na(names(selected_clusts)) & names(selected_clusts) != .... is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=0.1,
weights=weights,
n_clusters=10, p=30),
"is.integer(selected_feats) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=c(1L,
rep(2L,
2)),
weights=weights,
n_clusters=10, p=30),
"length(selected_feats) == length(unique(selected_feats)) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=sel_feats, weights=weights,
n_clusters=10, p=25),
"all(selected_feats %in% 1:p) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetSelectedClustersOutput(selected_clusts=sel_clusts,
selected_feats=sel_feats[1:8], weights=weights,
n_clusters=10, p=25),
"length(selected_clusts) <= length(selected_feats) is not TRUE",
fixed=TRUE)
})## Test passed with 14 successes.Tests for getSelectedClusters()
testthat::test_that("getSelectedClusters works", {
set.seed(26717)
x <- matrix(stats::rnorm(10*5), nrow=10, ncol=5)
y <- stats::rnorm(10)
good_clusters <- list("apple"=1:2, "banana"=3:4, "cantaloupe"=5)
css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res <- getSelectedClusters(css_res, weighting="sparse", cutoff=0.05,
min_num_clusts=1, max_num_clusts=NA)
testthat::expect_true(is.list(res))
testthat::expect_equal(length(res), 3)
testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
"weights"))
testthat::expect_true(length(res$selected_clusts) <=
length(res$selected_feats))
testthat::expect_true(is.numeric(res$selected_clusts))
testthat::expect_true(length(res$selected_clusts) >= 1)
testthat::expect_equal(length(names(res$selected_clusts)),
length(res$selected_clusts))
testthat::expect_equal(length(names(res$selected_clusts)),
length(unique(names(res$selected_clusts))))
testthat::expect_true(all(res$selected_clusts >= 0))
testthat::expect_true(all(res$selected_clusts <= 1))
testthat::expect_true(is.integer(res$selected_feats))
testthat::expect_true(length(res$selected_feats) >= 1)
testthat::expect_equal(length(names(res$selected_feats)),
length(unique(names(res$selected_feats))))
testthat::expect_true(all(res$selected_feats >= 1))
testthat::expect_true(all(res$selected_feats <= 5))
testthat::expect_equal(length(res$selected_feats),
length(unique(res$selected_feats)))
testthat::expect_equal(length(res$selected_clusts), length(res$weights))
for(i in 1:length(res$weights)){
weights_i <- res$weights[[i]]
num_nonzero_weights <- sum(weights_i > 0)
# For "sparse" weighting, either there should only be one nonzero weight and
# it should equal 1 (if there were no ties in selection proportions among
# cluster members) or the nonzero weights should all be
# 1/num_nonzero_weights
testthat::expect_true(all(weights_i[weights_i > 0] == 1/num_nonzero_weights))
}
# weighted_avg
res_weighted <- getSelectedClusters(css_res, weighting="weighted_avg",
cutoff=0.05, min_num_clusts=1,
max_num_clusts=NA)
testthat::expect_equal(length(res_weighted$selected_clusts),
length(res_weighted$weights))
for(i in 1:length(res_weighted$weights)){
weights_i <- res_weighted$weights[[i]]
testthat::expect_true(all(weights_i >= 0))
testthat::expect_true(all(weights_i <= 1))
}
# simple_avg
res_simple <- getSelectedClusters(css_res, weighting="simple_avg",
cutoff=0.05, min_num_clusts=1,
max_num_clusts=NA)
testthat::expect_equal(length(res_simple$selected_clusts),
length(res_simple$weights))
for(i in 1:length(res_simple$weights)){
weights_i <- res_simple$weights[[i]]
testthat::expect_equal(length(unique(weights_i)), 1)
testthat::expect_equal(length(weights_i), sum(weights_i > 0))
}
# Test min_num_clusts
res2 <- getSelectedClusters(css_res, weighting="weighted_avg", cutoff=1,
min_num_clusts=3, max_num_clusts=NA)
testthat::expect_true(is.list(res2))
testthat::expect_equal(length(res2$selected_clusts), 3)
res3 <- getSelectedClusters(css_res, weighting="sparse", cutoff=1,
min_num_clusts=2, max_num_clusts=NA)
testthat::expect_true(length(res3$selected_clusts) >= 2)
# Regression test (#10): getSelectedClusters works in integer count space
# (counts = round(prop * B); thresh = ceiling(cutoff * B)), so a cluster
# sitting exactly at the threshold is kept by an exact integer comparison --
# no float accumulation can drop it and break the max_num_clusts loop into
# returning MORE clusters than max_num_clusts. With B=10 and cluster
# proportions (0, 0.3, 0.2), cutoff=0.1 / min=1 / max=1 must return a single
# cluster: thresh=1 selects counts 3 and 2, then the max loop raises thresh to
# 3, leaving only c2 (the 0.3 cluster).
csm <- cbind(as.integer(rep(0, 10)),
as.integer(c(rep(1, 3), rep(0, 7))),
as.integer(c(rep(1, 2), rep(0, 8))))
clus_mat <- csm
colnames(clus_mat) <- c("c1", "c2", "c3")
feat_mat <- csm
colnames(feat_mat) <- c("f1", "f2", "f3")
mock_css <- list(feat_sel_mat=feat_mat, clus_sel_mat=clus_mat,
X=matrix(stats::rnorm(30), nrow=10, ncol=3,
dimnames=list(NULL, c("f1", "f2", "f3"))),
y=stats::rnorm(10),
clusters=list(c1=1L, c2=2L, c3=3L),
train_inds=integer())
class(mock_css) <- "cssr"
res_tie <- getSelectedClusters(mock_css, weighting="simple_avg", cutoff=0.1,
min_num_clusts=1, max_num_clusts=1)
testthat::expect_true(length(res_tie$selected_clusts) <= 1)
testthat::expect_identical(names(res_tie$selected_clusts), "c2")
# Test max_num_clusts
# Ensure there is at least one relevant feature
x2 <- x
x2[, 5] <- y
css_res2 <- css(X=x2, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res4 <- getSelectedClusters(css_res2, weighting="simple_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=1)
testthat::expect_true(is.list(res4))
testthat::expect_equal(length(res4$selected_clusts), 1)
res5 <- getSelectedClusters(css_res, weighting="weighted_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=2)
testthat::expect_true(length(res5$selected_clusts) <= 2)
# Name features
colnames(x) <- LETTERS[1:ncol(x)]
css_res3 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res <- getSelectedClusters(css_res3, weighting="sparse", cutoff=0.05,
min_num_clusts=1, max_num_clusts=NA)
testthat::expect_true(is.list(res))
testthat::expect_equal(length(res), 3)
testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
"weights"))
testthat::expect_true(length(res$selected_clusts) <=
length(res$selected_feats))
testthat::expect_true(is.numeric(res$selected_clusts))
testthat::expect_true(length(res$selected_clusts) >= 1)
testthat::expect_equal(length(names(res$selected_clusts)),
length(res$selected_clusts))
testthat::expect_equal(length(names(res$selected_clusts)),
length(unique(names(res$selected_clusts))))
testthat::expect_true(all(res$selected_clusts >= 0))
testthat::expect_true(all(res$selected_clusts <= 1))
testthat::expect_true(is.integer(res$selected_feats))
testthat::expect_true(length(res$selected_feats) >= 1)
testthat::expect_equal(length(names(res$selected_feats)),
length(unique(names(res$selected_feats))))
testthat::expect_true(all(res$selected_feats >= 1))
testthat::expect_true(all(res$selected_feats <= 5))
testthat::expect_equal(length(res$selected_feats),
length(unique(res$selected_feats)))
testthat::expect_equal(length(names(res$selected_feats)),
length(res$selected_feats))
testthat::expect_equal(length(names(res$selected_feats)),
length(unique(names(res$selected_feats))))
})
testthat::test_that("getSelectedClusters does not hang when min_num_clusts > n_clusters (#69)", {
# Minimal cssr object (same pattern as the #42 test) with 2 clusters.
# min_num_clusts = 5 exceeds the 2 available clusters: pre-#69 the min-loop
# decrements the cutoff forever; post-#69 the guard breaks once all clusters
# are selected, so checkSelectedClusters warns and the function returns them.
B <- 10
clusters <- list(c1 = 1:2, c2 = 3:4)
clus_sel_mat <- cbind(c1 = rep(1, B), c2 = c(rep(1, B - 1), 0))
feat_sel_mat <- cbind(X1 = rep(1, B), X2 = rep(1, B),
X3 = c(rep(1, B - 1), 0), X4 = c(rep(1, B - 1), 0))
obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat,
clusters = clusters), class = "cssr")
testthat::expect_warning(
res <- getSelectedClusters(obj, weighting = "simple_avg", cutoff = 0,
min_num_clusts = 5L, max_num_clusts = NA),
"Returning fewer than min_num_clusts", fixed = TRUE)
testthat::expect_equal(length(res$selected_clusts), 2L) # both clusters, no hang
})
testthat::test_that("getSelectedClusters max_num_clusts handles proportion-1.0 ties (#42)", {
# Minimal cssr object: cluster c1 at selection proportion 1.0 (count B),
# cluster c2 at (B - 1)/B (count B - 1, just below 1.0). With max_num_clusts =
# 1 the max loop raises the integer threshold until only the proportion-1.0
# cluster survives: thresh climbs to B, where count B >= B keeps c1 but count
# B - 1 < B drops c2. In integer count space this is exact and platform-
# independent for every B -- no float accumulation and no `cutoff > 1` break
# edge case (the loop simply stops once thresh > B) -- so the result is
# deterministically c1 for all of B in {9, 11, 20}.
make_obj <- function(B){
clusters <- list(c1 = 1:2, c2 = 3:4)
clus_sel_mat <- cbind(c1 = rep(1, B), c2 = c(rep(1, B - 1), 0))
feat_sel_mat <- cbind(X1 = rep(1, B), X2 = rep(1, B),
X3 = c(rep(1, B - 1), 0), X4 = c(rep(1, B - 1), 0))
obj <- list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat,
clusters = clusters)
class(obj) <- "cssr"
obj
}
for(B in c(9, 11, 20)){
res <- getSelectedClusters(make_obj(B), weighting = "simple_avg", cutoff = 0,
min_num_clusts = 1, max_num_clusts = 1)
# Only the proportion-1.0 cluster c1 survives; c2 at (B-1)/B is below 1.
testthat::expect_identical(names(res$selected_clusts), "c1")
testthat::expect_equal(unname(res$selected_clusts), 1)
}
})
testthat::test_that("getSelectedClusters applies cutoff as an exact >= threshold (#159a)", {
# Count-space selection makes ">= cutoff" hold EXACTLY: a cluster is selected
# at a given cutoff iff its selection proportion is at least that cutoff, with
# no float snapping to the nearest 1/B grid point. Mock with proportions
# {1.0, 0.7, 0.5} at B = 10; the 1.0 and 0.7 clusters GUARD the min-loop (the
# selection is never empty, so min_num_clusts = 1 cannot lower the threshold
# and re-include an excluded cluster). Pre-#159a the old `cutoff - 1/(2B)`
# snap selected 0.5 at cutoff 0.52 and 0.7 at cutoff 0.71, so this test FAILS
# on the old code; post-fix each is excluded once the cutoff exceeds it.
B <- 10
clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L)
props <- c(1.0, 0.7, 0.5)
clus_sel_mat <- do.call(cbind, lapply(props, function(p)
as.integer(c(rep(1, round(p * B)), rep(0, B - round(p * B))))))
colnames(clus_sel_mat) <- c("c1", "c2", "c3")
feat_sel_mat <- clus_sel_mat
colnames(feat_sel_mat) <- c("f1", "f2", "f3")
obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat,
clusters = clusters), class = "cssr")
sel <- function(cut) names(getSelectedClusters(obj, weighting = "simple_avg",
cutoff = cut, min_num_clusts = 1, max_num_clusts = NA)$selected_clusts)
# 0.5 cluster (c3): selected AT cutoff 0.5 (thresh 5), NOT at 0.52 (thresh 6).
testthat::expect_true("c3" %in% sel(0.5))
testthat::expect_false("c3" %in% sel(0.52))
# 0.7 cluster (c2): selected AT cutoff 0.7 (thresh 7), NOT at 0.71 (thresh 8).
testthat::expect_true("c2" %in% sel(0.7))
testthat::expect_false("c2" %in% sel(0.71))
})## Test passed with 60 successes.## Test passed with 2 successes.## Test passed with 6 successes.## Test passed with 4 successes.Finally, tests for getCssSelections()
testthat::test_that("getCssSelections works", {
set.seed(26717)
x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
y <- stats::rnorm(10)
good_clusters <- list("apple"=1:2, "banana"=3:4, "cantaloupe"=5)
css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res <- getCssSelections(css_res)
testthat::expect_true(is.list(res))
testthat::expect_equal(length(res), 3)
testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
"weights"))
testthat::expect_true(length(res$selected_clusts) <=
length(res$selected_feats))
testthat::expect_true(is.list(res$selected_clusts))
testthat::expect_equal(length(names(res$selected_clusts)),
length(res$selected_clusts))
testthat::expect_equal(length(names(res$selected_clusts)),
length(unique(names(res$selected_clusts))))
already_used_feats <- integer()
for(i in 1:length(res$selected_clusts)){
sels_i <- res$selected_clusts[[i]]
testthat::expect_true(length(sels_i) >= 1)
testthat::expect_true(is.integer(sels_i))
testthat::expect_true(all(sels_i %in% 1:11))
testthat::expect_equal(length(sels_i), length(unique(sels_i)))
testthat::expect_equal(length(intersect(already_used_feats, sels_i)), 0)
already_used_feats <- c(already_used_feats, sels_i)
}
testthat::expect_true(length(already_used_feats) <= 11)
testthat::expect_equal(length(already_used_feats),
length(unique(already_used_feats)))
testthat::expect_true(all(already_used_feats %in% 1:11))
testthat::expect_true(is.integer(res$selected_feats))
testthat::expect_true(length(res$selected_feats) >= 1)
testthat::expect_equal(length(names(res$selected_feats)),
length(unique(names(res$selected_feats))))
testthat::expect_true(all(res$selected_feats >= 1))
testthat::expect_true(all(res$selected_feats <= 7))
testthat::expect_equal(length(res$selected_feats),
length(unique(res$selected_feats)))
testthat::expect_equal(length(res$selected_clusts), length(res$weights))
for(i in 1:length(res$weights)){
weights_i <- res$weights[[i]]
num_nonzero_weights <- sum(weights_i > 0)
# For "sparse" weighting, either there should only be one nonzero weight and
# it should equal 1 (if there were no ties in selection proportions among
# cluster members) or the nonzero weights should all be
# 1/num_nonzero_weights
testthat::expect_true(all(weights_i[weights_i > 0] == 1/num_nonzero_weights))
}
# Test min_num_clusts (should be 5 clusters--3 named ones, plus last two get
# put in their own unnamed clusters automatically by css)
res2 <- getCssSelections(css_res, weighting="weighted_avg", cutoff=1,
min_num_clusts=5, max_num_clusts=NA)
testthat::expect_true(is.list(res2))
testthat::expect_equal(length(res2$selected_clusts), 5)
res3 <- getCssSelections(css_res, weighting="sparse", cutoff=1,
min_num_clusts=3, max_num_clusts=NA)
testthat::expect_true(length(res3$selected_clusts) >= 3)
# Test max_num_clusts
# Ensure there is at least one relevant feature
x2 <- x
x2[, 5] <- y
css_res2 <- css(X=x2, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res4 <- getCssSelections(css_res2, weighting="simple_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=1)
testthat::expect_true(is.list(res4))
testthat::expect_equal(length(res4$selected_clusts), 1)
res5 <- getCssSelections(css_res, weighting="weighted_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=2)
testthat::expect_true(length(res5$selected_clusts) <= 2)
# Name features
colnames(x) <- LETTERS[1:ncol(x)]
css_res3 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 10)
res <- getCssSelections(css_res3, weighting="sparse", cutoff=0.05,
min_num_clusts=1, max_num_clusts=NA)
testthat::expect_true(is.list(res))
testthat::expect_equal(length(res), 3)
testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
"weights"))
testthat::expect_true(length(res$selected_clusts) <=
length(res$selected_feats))
testthat::expect_equal(length(names(res$selected_feats)),
length(res$selected_feats))
testthat::expect_equal(length(names(res$selected_feats)),
length(unique(names(res$selected_feats))))
# Bad inputs
# Error has quotation marks in it
testthat::expect_error(getCssSelections("css_results"))
testthat::expect_error(getCssSelections(css_res, weighting="spasre"),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(getCssSelections(css_res, cutoff=-.5),
"cutoff >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssSelections(css_res, min_num_clusts=-1),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssSelections(css_res, max_num_clusts=50),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
testthat::expect_error(getCssSelections(css_res, max_num_clusts=4.5),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
})## Test passed with 65 successes.Test for min_num_clusts = 0 (empty threshold selection, issue #107):
testthat::test_that("min_num_clusts = 0 allows an empty threshold selection", {
# Deterministic empty-producing fixture: a fixed seed, all-singleton clusters
# (clusters = list(), so every feature is its own cluster), and a large lambda
# so the base lasso selects almost nothing. We assert that the maximum cluster
# selection proportion is below 1 - 1/(2*B) so that cutoff = 1 genuinely
# selects no cluster (otherwise the test would not exercise the empty path).
set.seed(8)
B <- 10
x <- matrix(stats::rnorm(30*8), nrow=30, ncol=8)
y <- stats::rnorm(30)
css_res <- css(X=x, y=y, lambda=0.5, clusters=list(), B=B)
testthat::expect_true(max(colMeans(css_res$clus_sel_mat)) < 1 - 1/(2*B))
# Selection path: getCssSelections returns a clean empty result. (weights is a
# NAMED empty list, so assert via length/type rather than expect_equal(.,list()).)
empty_sel <- getCssSelections(css_res, cutoff=1, min_num_clusts=0)
testthat::expect_length(empty_sel$selected_clusts, 0)
testthat::expect_true(is.list(empty_sel$selected_clusts))
testthat::expect_length(empty_sel$selected_feats, 0)
testthat::expect_true(is.integer(empty_sel$selected_feats))
testthat::expect_length(empty_sel$weights, 0)
testthat::expect_true(is.list(empty_sel$weights))
# Design / prediction paths: one clear error (no design/predictions possible).
testthat::expect_error(getCssDesign(css_res, newX=x, cutoff=1,
min_num_clusts=0),
"No clusters were selected", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x, trainX=x, trainY=y,
cutoff=1, min_num_clusts=0),
"No clusters were selected", fixed=TRUE)
# Legacy regression: the default min_num_clusts = 1 still forces >= 1 cluster
# on the SAME fixture (the floor of 1 is unchanged).
legacy_sel <- getCssSelections(css_res, cutoff=1, min_num_clusts=1)
testthat::expect_equal(length(legacy_sel$selected_clusts), 1)
})## Test passed with 10 successes.Tests for checkXInputResults()
testthat::test_that("checkXInputResults works", {
set.seed(72617)
x_select <- matrix(stats::rnorm(10*5), nrow=10, ncol=5)
x_new <- matrix(stats::rnorm(8*5), nrow=8, ncol=5)
y_select <- stats::rnorm(10)
y_new <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- checkXInputResults(x_new, css_res$X)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("feat_names", "newx"))
testthat::expect_true(is.character(res$feat_names))
testthat::expect_true(is.na(res$feat_names))
testthat::expect_true(is.numeric(res$newx))
testthat::expect_true(is.matrix(res$newx))
testthat::expect_equal(nrow(res$newx), 8)
testthat::expect_equal(ncol(res$newx), 5)
testthat::expect_null(colnames(res$newx))
# Try naming variables
colnames(x_select) <- LETTERS[1:5]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(checkXInputResults(x_new, css_res_named$X),
"New X provided had no variable names (column names) even though the X provided to css did.",
fixed=TRUE)
# Try mismatching variable names
colnames(x_new) <- LETTERS[2:6]
testthat::expect_error(checkXInputResults(x_new, css_res_named$X),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_new) <- LETTERS[1:5]
res_named <- checkXInputResults(x_new, css_res_named$X)
testthat::expect_true(is.list(res_named))
testthat::expect_identical(names(res_named), c("feat_names", "newx"))
testthat::expect_true(is.character(res_named$feat_names))
testthat::expect_identical(res_named$feat_names, LETTERS[1:5])
# Try data.frame input to css and checkXInputResults
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/2)
fit_inds <- setdiff(1:n, selec_inds)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkXInputResults(X_df[fit_inds, ], css_res_df$X)
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("feat_names", "newx"))
testthat::expect_true(is.character(res_df$feat_names))
testthat::expect_identical(res_df$feat_names, colnames(css_res_df$X))
testthat::expect_identical(res_df$feat_names, colnames(X_df))
testthat::expect_true(is.numeric(res_df$newx))
testthat::expect_true(is.matrix(res_df$newx))
testthat::expect_null(colnames(res_df$newx))
testthat::expect_equal(ncol(res_df$newx), ncol(css_res_df$X))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
# cyl, gear, and carb are factors with more than 2 levels
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkXInputResults(X_df[fit_inds, ], css_res_df$X)
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("feat_names", "newx"))
testthat::expect_true(is.character(res_df$feat_names))
testthat::expect_identical(res_df$feat_names, colnames(css_res_df$X))
mat <- model.matrix( ~., X_df)
mat <- mat[, colnames(mat) != "(Intercept)"]
testthat::expect_identical(res_df$feat_names, colnames(mat))
testthat::expect_true(is.numeric(res_df$newx))
testthat::expect_true(is.matrix(res_df$newx))
testthat::expect_null(colnames(res_df$newx))
testthat::expect_equal(ncol(res_df$newx), ncol(css_res_df$X))
})## Test passed with 33 successes.Tests for checkNewXProvided()
testthat::test_that("checkNewXProvided works", {
set.seed(2673)
x_select <- matrix(stats::rnorm(10*5), nrow=10, ncol=5)
x_new <- matrix(stats::rnorm(8*5), nrow=8, ncol=5)
y_select <- stats::rnorm(10)
y_new <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- checkNewXProvided(x_new, css_res)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(is.numeric(res$newX))
testthat::expect_true(is.matrix(res$newX))
testthat::expect_equal(nrow(res$newX), 8)
testthat::expect_equal(ncol(res$newX), 5)
testthat::expect_null(colnames(res$newX))
# #153a: an unnamed newx yields feat_names == NA (scalar).
testthat::expect_true(is.na(res$feat_names))
testthat::expect_equal(length(res$feat_names), 1)
testthat::expect_true(is.logical(res$newXProvided))
testthat::expect_equal(length(res$newXProvided), 1)
testthat::expect_true(!is.na(res$newXProvided))
testthat::expect_true(res$newXProvided)
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- checkNewXProvided(x_new, css_res_train)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(all(abs(x_new - res$newX) < 10^(-9)))
testthat::expect_true(res$newXProvided)
# Things should still work if new x is not provided
res <- checkNewXProvided(NA, css_res_train)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(is.numeric(res$newX))
testthat::expect_true(is.matrix(res$newX))
testthat::expect_equal(nrow(res$newX), 5)
testthat::expect_equal(ncol(res$newX), 5)
testthat::expect_null(colnames(res$newX))
testthat::expect_false(res$newXProvided)
# An NA-containing newX was previously read as "not provided" (the
# all(!is.na) sentinel) and silently replaced by the train_inds data; it is
# now treated as provided and rejected by checkNoNAs (#71).
x_na <- x_new
x_na[3, 2] <- NA
testthat::expect_error(checkNewXProvided(x_na, css_res_train),
"must not contain missing", fixed = TRUE)
# Try not providing training indices and omitting newx--should get error
testthat::expect_error(checkNewXProvided(NA, css_res),
"css was not provided with indices to set aside for model training (train_inds), so must provide new X in order to generate a design matrix", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:5]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(checkNewXProvided(x_new, css_res_named),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_new) <- LETTERS[2:6]
testthat::expect_error(checkNewXProvided(x_new, css_res_named),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_new) <- LETTERS[1:5]
res_named <- checkNewXProvided(x_new, css_res_named)
testthat::expect_true(is.list(res_named))
testthat::expect_identical(names(res_named), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(all(abs(x_new - res_named$newX) < 10^(-9)))
testthat::expect_true(res_named$newXProvided)
# #153a: a named newx yields feat_names == the (validated) column names.
testthat::expect_identical(res_named$feat_names, LETTERS[1:5])
# Try data.frame input to css and checkNewXProvided
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/2)
fit_inds <- setdiff(1:n, selec_inds)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkNewXProvided(X_df[fit_inds, ], css_res_df)
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(is.numeric(res_df$newX))
testthat::expect_true(is.matrix(res_df$newX))
testthat::expect_equal(nrow(res_df$newX), length(fit_inds))
testthat::expect_equal(ncol(res_df$newX), ncol(css_res_df$X))
testthat::expect_null(colnames(res_df$newX))
testthat::expect_true(is.logical(res_df$newXProvided))
testthat::expect_equal(length(res_df$newXProvided), 1)
testthat::expect_true(!is.na(res_df$newXProvided))
testthat::expect_true(res_df$newXProvided)
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkNewXProvided(X_df[fit_inds, ], css_res_df)
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("newX", "newXProvided", "feat_names"))
testthat::expect_true(is.numeric(res_df$newX))
testthat::expect_true(is.matrix(res_df$newX))
testthat::expect_equal(nrow(res_df$newX), length(fit_inds))
testthat::expect_equal(ncol(res_df$newX), ncol(css_res_df$X))
testthat::expect_null(colnames(res_df$newX))
testthat::expect_true(is.logical(res_df$newXProvided))
testthat::expect_equal(length(res_df$newXProvided), 1)
testthat::expect_true(!is.na(res_df$newXProvided))
testthat::expect_true(res_df$newXProvided)
# (#104, L5) Dispatch on the NA-sentinel default, not a length() heuristic.
# css_res_train has train_inds, so the OLD length()-based code silently fell
# back to that training data for these misclassified inputs; they must now be
# treated as "provided".
# A bare numeric vector (length > 1) is not a valid design matrix and now
# errors clearly instead of failing later on a cryptic is.matrix() stopifnot.
testthat::expect_error(
checkNewXProvided(stats::rnorm(5), css_res_train),
"newX must be a matrix or data.frame", fixed=TRUE)
# A one-column data.frame (length 1) used to be misread as "not provided" and
# silently replaced by the train_inds data; it now enters the provided branch
# and errors (here on a feature-name/column mismatch) rather than falling back.
testthat::expect_error(
checkNewXProvided(data.frame(a=stats::rnorm(8)), css_res_train))
})## Test passed with 58 successes.Tests for checkFormCssDesignInputs()
testthat::test_that("checkFormCssDesignInputs works", {
set.seed(72617)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
x_new <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
y_select <- stats::rnorm(10)
y_new <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- checkFormCssDesignInputs(css_results=css_res, weighting="sparse",
cutoff=0.5, min_num_clusts=1,
max_num_clusts=NA, newx=x_new)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res$newx))
testthat::expect_true(is.matrix(res$newx))
testthat::expect_equal(nrow(res$newx), 8)
testthat::expect_equal(ncol(res$newx), 6)
testthat::expect_null(colnames(res$newx))
testthat::expect_true(all(abs(x_new - res$newX) < 10^(-9)))
testthat::expect_equal(length(res$max_num_clusts), 1)
testthat::expect_true(is.na(res$max_num_clusts))
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B=10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- checkFormCssDesignInputs(css_results=css_res_train,
weighting="weighted_avg", cutoff=0,
min_num_clusts=2, max_num_clusts=NA,
newx=x_new)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res$newx))
testthat::expect_true(is.matrix(res$newx))
testthat::expect_equal(nrow(res$newx), 8)
testthat::expect_equal(ncol(res$newx), 6)
testthat::expect_null(colnames(res$newx))
testthat::expect_true(all(abs(x_new - res$newX) < 10^(-9)))
# Things should still work if new x is not provided
res <- checkFormCssDesignInputs(css_results=css_res_train, weighting="sparse",
cutoff=1, min_num_clusts=3,
max_num_clusts=NA, newx=NA)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res$newx))
testthat::expect_true(is.matrix(res$newx))
testthat::expect_equal(nrow(res$newx), length(6:10))
testthat::expect_equal(ncol(res$newx), 6)
testthat::expect_null(colnames(res$newx))
testthat::expect_true(all(abs(x_select[1:5, ] - res$newX) < 10^(-9)))
# Try not providing training indices and omitting newx--should get error
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="sparse",
cutoff=0.5, min_num_clusts=1,
max_num_clusts=5, newx=NA),
"If css was not provided with indices to set aside for model training, then newx must be provided to formCssDesign", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:6]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(checkFormCssDesignInputs(css_results=css_res_named,
weighting="simple_avg",
cutoff=0.9,
min_num_clusts=1,
max_num_clusts=3,
newx=x_new),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_new) <- LETTERS[2:7]
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res_named,
weighting="weighted_avg",
cutoff=0.2, min_num_clusts=1,
max_num_clusts=1,
newx=x_new),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_new) <- LETTERS[1:6]
res_named <- checkFormCssDesignInputs(css_results=css_res_named,
weighting="sparse", cutoff=0.5,
min_num_clusts=2, max_num_clusts=NA,
newx=x_new)
testthat::expect_true(is.list(res_named))
testthat::expect_identical(names(res_named), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res_named$newx))
testthat::expect_true(is.matrix(res_named$newx))
testthat::expect_equal(nrow(res_named$newx), 8)
testthat::expect_equal(ncol(res_named$newx), 6)
testthat::expect_null(colnames(res_named$newx))
testthat::expect_identical(colnames(css_res_named$X), LETTERS[1:6])
testthat::expect_true(all(abs(x_new - res_named$newX) < 10^(-9)))
# Try data.frame input to css and checkFormCssDesignInputs
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/2)
fit_inds <- setdiff(1:n, selec_inds)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkFormCssDesignInputs(css_results=css_res_df,
weighting="simple_avg", cutoff=0.7,
min_num_clusts=3, max_num_clusts=NA,
newx=X_df[fit_inds, ])
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res_df$newx))
testthat::expect_true(is.matrix(res_df$newx))
testthat::expect_null(colnames(res_df$newx))
testthat::expect_equal(nrow(res_df$newx), length(fit_inds))
testthat::expect_equal(ncol(res_df$newx), ncol(css_res_df$X))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkFormCssDesignInputs(css_results=css_res_df,
weighting="weighted_avg", cutoff=0.3,
min_num_clusts=1, max_num_clusts=4,
newx=X_df[fit_inds, ])
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("newx", "max_num_clusts"))
testthat::expect_true(is.numeric(res_df$newx))
testthat::expect_true(is.matrix(res_df$newx))
testthat::expect_null(colnames(res_df$newx))
testthat::expect_equal(nrow(res_df$newx), length(fit_inds))
testthat::expect_equal(ncol(res_df$newx), ncol(css_res_df$X))
##### Try other bad inputs
colnames(x_new) <- NULL
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=-0.3, min_num_clusts=1,
max_num_clusts=4,
newx=x_new),
"cutoff >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="sparse",
cutoff="0.5",
min_num_clusts=1,
max_num_clusts=NA, newx=x_new),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="sparse",
cutoff=as.numeric(NA),
min_num_clusts=1,
max_num_clusts=NA,
newx=x_new),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting=c("sparse",
"simple_avg"),
cutoff=0.2,
min_num_clusts=1,
max_num_clusts=NA,
newx=x_new),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting=1,
cutoff=0.2,
min_num_clusts=1,
max_num_clusts=NA,
newx=x_new),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="spasre",
cutoff=0.2,
min_num_clusts=1,
max_num_clusts=NA,
newx=x_new),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=c(1, 2),
max_num_clusts=NA,
newx=x_new),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts="3",
max_num_clusts=NA,
newx=x_new),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=-1,
max_num_clusts=NA,
newx=x_new),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=6,
max_num_clusts=NA,
newx=x_new),
"min_num_clusts <= n_clusters is not TRUE", fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=1,
max_num_clusts="4",
newx=x_new),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=1,
max_num_clusts=3.5,
newx=x_new),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=2,
max_num_clusts=1,
newx=x_new),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(checkFormCssDesignInputs(css_results=css_res,
weighting="weighted_avg",
cutoff=0.2,
min_num_clusts=2,
max_num_clusts=8,
newx=x_new),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
})## Test passed with 66 successes.Tests for formCssDesign()
testthat::test_that("formCssDesign works", {
set.seed(17230)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
x_new <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
y_select <- stats::rnorm(10)
y_new <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- formCssDesign(css_res, newx=x_new)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 8)
testthat::expect_equal(ncol(res), length(css_res$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res$clusters)))
testthat::expect_true(all(names(css_res$clusters) %in% colnames(res)))
# Value-level checks: pin every entry of the design matrix to a hand-computed
# value across all three weighting schemes (#101). The structural checks above
# would pass for a wrong-but-well-shaped design (column misalignment,
# transposed/reversed weights, or one cluster's weights applied to another).
feat_sel_props <- colMeans(css_res$feat_sel_mat)
for (w in c("simple_avg", "weighted_avg", "sparse")) {
des <- formCssDesign(css_res, weighting = w, cutoff = 0, min_num_clusts = 1, newx = x_new)
wts <- getSelectedClusters(css_res, weighting = w, cutoff = 0,
min_num_clusts = 1, max_num_clusts = NA)$weights
# exported-path equivalence (getCssDesign just forwards to formCssDesign)
testthat::expect_equal(
getCssDesign(css_res, newX = x_new, weighting = w, cutoff = 0, min_num_clusts = 1), des)
for (name in names(wts)) {
clust <- css_res$clusters[[name]]
w_i <- wts[[name]]
sp <- feat_sel_props[clust]
# (1) APPLICATION: weights applied to the correct columns, correct orientation, correct cluster
testthat::expect_equal(des[, name],
as.numeric(x_new[, clust, drop = FALSE] %*% w_i), info = paste(w, name))
# (2) SEMANTIC anchor per scheme (independent of getSelectedClusters$weights)
if (w == "simple_avg") {
testthat::expect_equal(des[, name], rowMeans(x_new[, clust, drop = FALSE]), info = name)
} else if (w == "weighted_avg") {
if (sum(sp) > 0) {
testthat::expect_equal(unname(w_i), unname(sp / sum(sp)), info = name)
} else {
testthat::expect_equal(unname(w_i), rep(1 / length(clust), length(clust)), info = name)
}
} else { # sparse: equal weight on the member(s) tied at max(sp); else equal weights
if (sum(sp) > 0) {
maxes <- sp == max(sp)
testthat::expect_equal(des[, name],
as.numeric(rowMeans(x_new[, clust[maxes], drop = FALSE])), info = name)
} else {
testthat::expect_equal(des[, name], rowMeans(x_new[, clust, drop = FALSE]), info = name)
}
}
}
}
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B=10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- formCssDesign(css_results=css_res_train, weighting="weighted_avg",
cutoff=0, min_num_clusts=2, max_num_clusts=NA,
newx=x_new)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 8)
testthat::expect_equal(ncol(res), length(css_res_train$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res_train$clusters)))
testthat::expect_true(all(names(css_res_train$clusters) %in% colnames(res)))
# Things should still work if new x is not provided
res <- formCssDesign(css_results=css_res_train, weighting="weighted_avg",
cutoff=0, min_num_clusts=2, max_num_clusts=NA)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 5)
testthat::expect_equal(ncol(res), length(css_res_train$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res_train$clusters)))
testthat::expect_true(all(names(css_res_train$clusters) %in% colnames(res)))
# Try not providing training indices and omitting newx--should get error
testthat::expect_error(formCssDesign(css_results=css_res, weighting="sparse",
cutoff=0.5, min_num_clusts=1,
max_num_clusts=5, newx=NA),
"If css was not provided with indices to set aside for model training, then newx must be provided to formCssDesign", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:6]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(formCssDesign(css_results=css_res_named,
weighting="simple_avg", cutoff=0.9,
min_num_clusts=1, max_num_clusts=3,
newx=x_new),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_new) <- LETTERS[2:7]
testthat::expect_error(formCssDesign(css_results=css_res_named,
weighting="weighted_avg", cutoff=0.2,
min_num_clusts=1, max_num_clusts=1,
newx=x_new),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_new) <- LETTERS[1:6]
res_named <- formCssDesign(css_results=css_res_named,
weighting="sparse", cutoff=0.5,
min_num_clusts=2, max_num_clusts=NA,
newx=x_new)
testthat::expect_true(is.matrix(res_named))
testthat::expect_true(is.numeric(res_named))
testthat::expect_equal(nrow(res_named), 8)
testthat::expect_true(ncol(res_named) <= length(css_res_named$clusters))
testthat::expect_true(all(colnames(res_named) %in% names(css_res_named$clusters)))
# Try data.frame input to css and formCssDesign
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/2)
fit_inds <- setdiff(1:n, selec_inds)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- formCssDesign(css_results=css_res_df, weighting="simple_avg",
cutoff=0.7, min_num_clusts=3, max_num_clusts=NA,
newx=X_df[fit_inds, ])
testthat::expect_true(is.matrix(res_df))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(nrow(res_df), length(fit_inds))
testthat::expect_true(ncol(res_df) <= length(css_res_df$clusters))
testthat::expect_true(all(colnames(res_df) %in% names(css_res_df$clusters)))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- formCssDesign(css_results=css_res_df, weighting="weighted_avg",
cutoff=0.3, min_num_clusts=1, max_num_clusts=4,
newx=X_df[fit_inds, ])
testthat::expect_true(is.matrix(res_df))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(nrow(res_df), length(fit_inds))
testthat::expect_true(ncol(res_df) <= length(css_res_df$clusters))
testthat::expect_true(all(colnames(res_df) %in% names(css_res_df$clusters)))
##### Try other bad inputs
colnames(x_new) <- NULL
testthat::expect_error(formCssDesign(css_results=css_res, cutoff=-0.3,
newx=x_new), "cutoff >= 0 is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, cutoff="0.5",
newx=x_new),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res,
cutoff=as.numeric(NA), newx=x_new),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res,
weighting=c("sparse", "simple_avg"),
newx=x_new),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, weighting=1,
newx=x_new),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, weighting="spasre",
newx=x_new),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res,
min_num_clusts=c(1, 2), newx=x_new),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, min_num_clusts="3",
newx=x_new),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, min_num_clusts=-1,
newx=x_new),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, min_num_clusts=6,
newx=x_new),
"min_num_clusts <= n_clusters is not TRUE", fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, max_num_clusts="4",
newx=x_new),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, max_num_clusts=3.5,
newx=x_new),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, min_num_clusts=2,
max_num_clusts=1, newx=x_new),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(formCssDesign(css_results=css_res, max_num_clusts=8,
newx=x_new),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
})## Test passed with 77 successes.Finally, tests for getCssDesign()
testthat::test_that("getCssDesign works", {
set.seed(23170)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
x_new <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
y_select <- stats::rnorm(10)
y_new <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- getCssDesign(css_res, newX=x_new)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 8)
testthat::expect_equal(ncol(res), length(css_res$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res$clusters)))
testthat::expect_true(all(names(css_res$clusters) %in% colnames(res)))
# A single-row newX is accepted (#44): getCssDesign used to require > 1 row,
# while getCssPreds/cssPredict already accept a 1-row test set.
res_1row <- getCssDesign(css_res, newX = x_new[1, , drop = FALSE])
testthat::expect_true(is.matrix(res_1row))
testthat::expect_equal(nrow(res_1row), 1)
testthat::expect_equal(ncol(res_1row), length(css_res$clusters))
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B=10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- getCssDesign(css_results=css_res_train, weighting="weighted_avg",
min_num_clusts=2, newX=x_new)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 8)
testthat::expect_equal(ncol(res), length(css_res_train$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res_train$clusters)))
testthat::expect_true(all(names(css_res_train$clusters) %in% colnames(res)))
# Things should still work if new x is not provided
res <- getCssDesign(css_results=css_res_train, min_num_clusts=2)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(nrow(res), 5)
testthat::expect_equal(ncol(res), length(css_res_train$clusters))
testthat::expect_true(all(colnames(res) %in% names(css_res_train$clusters)))
testthat::expect_true(all(names(css_res_train$clusters) %in% colnames(res)))
# Try not providing training indices and omitting newX--should get error
testthat::expect_error(getCssDesign(css_results=css_res, weighting="sparse",
cutoff=0.5, min_num_clusts=1,
max_num_clusts=5, newX=NA),
"css was not provided with indices to set aside for model training (train_inds), so must provide new X in order to generate a design matrix", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:6]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(getCssDesign(css_results=css_res_named,
weighting="simple_avg", cutoff=0.9,
min_num_clusts=1, max_num_clusts=3,
newX=x_new),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_new) <- LETTERS[2:7]
testthat::expect_error(getCssDesign(css_results=css_res_named,
weighting="weighted_avg", cutoff=0.2,
min_num_clusts=1, max_num_clusts=1,
newX=x_new),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_new) <- LETTERS[1:6]
res_named <- getCssDesign(css_results=css_res_named, weighting="sparse",
cutoff=0.5, min_num_clusts=2, max_num_clusts=NA,
newX=x_new)
testthat::expect_true(is.matrix(res_named))
testthat::expect_true(is.numeric(res_named))
testthat::expect_equal(nrow(res_named), 8)
testthat::expect_true(ncol(res_named) <= length(css_res_named$clusters))
testthat::expect_true(all(colnames(res_named) %in% names(css_res_named$clusters)))
# Try data.frame input to css and getCssDesign
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/2)
fit_inds <- setdiff(1:n, selec_inds)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
# #142: the data.frame newX path must NOT emit the spurious "no variable names"
# warning (checkXInputResults strips the coerced names; getCssDesign re-attaches
# the already-validated ones before formCssDesign).
df_warns <- character(0)
res_df <- withCallingHandlers(
getCssDesign(css_results=css_res_df, weighting="simple_avg",
cutoff=0.7, min_num_clusts=3, max_num_clusts=NA,
newX=X_df[fit_inds, ]),
warning=function(w){ df_warns <<- c(df_warns, conditionMessage(w));
invokeRestart("muffleWarning") })
testthat::expect_false(any(grepl("no variable names", df_warns, fixed=TRUE)))
testthat::expect_true(is.matrix(res_df))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(nrow(res_df), length(fit_inds))
testthat::expect_true(ncol(res_df) <= length(css_res_df$clusters))
testthat::expect_true(all(colnames(res_df) %in% names(css_res_df$clusters)))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- getCssDesign(css_results=css_res_df, weighting="weighted_avg",
cutoff=0.3, min_num_clusts=1, max_num_clusts=4,
newX=X_df[fit_inds, ])
testthat::expect_true(is.matrix(res_df))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(nrow(res_df), length(fit_inds))
testthat::expect_true(ncol(res_df) <= length(css_res_df$clusters))
testthat::expect_true(all(colnames(res_df) %in% names(css_res_df$clusters)))
##### Try other bad inputs
colnames(x_new) <- NULL
testthat::expect_error(getCssDesign(css_results=css_res, cutoff=-0.3,
newX=x_new), "cutoff >= 0 is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, cutoff="0.5",
newX=x_new),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res,
cutoff=as.numeric(NA), newX=x_new),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res,
weighting=c("sparse", "simple_avg"),
newX=x_new),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, weighting=1,
newX=x_new),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, weighting="spasre",
newX=x_new),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res,
min_num_clusts=c(1, 2), newX=x_new),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, min_num_clusts="3",
newX=x_new),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, min_num_clusts=-1,
newX=x_new),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, min_num_clusts=6,
newX=x_new),
"min_num_clusts <= n_clusters is not TRUE", fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, max_num_clusts="4",
newX=x_new),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, max_num_clusts=3.5,
newX=x_new),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, min_num_clusts=2,
max_num_clusts=1, newX=x_new),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssDesign(css_results=css_res, max_num_clusts=8,
newX=x_new),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
})## Test passed with 54 successes.A realistic column misalignment – same-named columns supplied in a different
order – surfaces the curated name-mismatch message rather than a raw internal
identical(...) assertion (issue #153, item e).
testthat::test_that("getCssDesign: reordered same-named columns give the curated name-mismatch error (#153e)", {
set.seed(153)
n <- 60; p <- 8
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
colnames(X) <- paste0("V", 1:p)
y <- X[, 1] + X[, 2] + stats::rnorm(n)
clusters <- list(c1 = 1:3)
res_ti <- css(X = X[1:40, ], y = y[1:40], lambda = 0.01, clusters = clusters,
B = 10, train_inds = 21:40)
# Reordered (same-named) columns used to surface the raw internal
# `identical(feat_names, colnames(css_X)) is not TRUE` assertion instead of the
# curated, user-facing message.
testthat::expect_error(
getCssDesign(res_ti, newX = X[41:60, c(2, 1, 3:8)]),
"Provided feature names for newx do not match", fixed = TRUE)
})## Test passed with 1 success.A single held-out training index (length-1 train_inds) is enough to build a
design matrix – one row of cluster representatives (#127). It used to crash
because css_results$X[css_results$train_inds, ] dropped to a vector in both
checkNewXProvided and checkFormCssDesignInputs.
testthat::test_that("getCssDesign/getCssPreds handle length-1 train_inds (#127)", {
set.seed(51274)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
y_select <- stats::rnorm(10)
x_pred <- matrix(stats::rnorm(4*6), nrow=4, ncol=6)
# clusters covers features 1:3; features 4, 5, 6 become singleton clusters, so
# css_res has 4 clusters. train_inds = 5L sets aside a single observation.
css_res <- css(X=x_select, y=y_select, lambda=0.01,
clusters=list(cluster1=1:3), B=10, train_inds=5L)
# getCssDesign with no newX re-derives the design from the single training row
# and must return a 1 x (#clusters) matrix without error.
des <- getCssDesign(css_res)
testthat::expect_true(is.matrix(des))
testthat::expect_true(is.numeric(des))
testthat::expect_equal(nrow(des), 1)
testthat::expect_equal(ncol(des), length(css_res$clusters))
# getCssPreds with the same length-1 train_inds cannot fit OLS (1 training row
# is not more than the number of clusters + intercept): it must fail with the
# clean OLS-size guard message, NOT a subscript/matrix crash. This guard is
# deliberate -- 1 training row genuinely cannot fit the prediction model.
testthat::expect_error(getCssPreds(css_res, testX=x_pred),
"not provided with enough indices to fit OLS",
fixed=TRUE)
# A length-2 train_inds still yields a valid 2-row design (no regression).
css_res2 <- css(X=x_select, y=y_select, lambda=0.01,
clusters=list(cluster1=1:3), B=10, train_inds=c(5L, 6L))
des2 <- getCssDesign(css_res2)
testthat::expect_true(is.matrix(des2))
testthat::expect_equal(nrow(des2), 2)
testthat::expect_equal(ncol(des2), length(css_res2$clusters))
})## Test passed with 8 successes.Tests for checkGetCssPredsInputs()
testthat::test_that("checkGetCssPredsInputs works", {
set.seed(17081)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
x_train <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
x_pred <- matrix(stats::rnorm(7*6), nrow=7, ncol=6)
y_select <- stats::rnorm(10)
y_train <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- checkGetCssPredsInputs(css_res, testX=x_pred, weighting="simple_avg",
cutoff=0.05, min_num_clusts=1,
max_num_clusts=NA, trainX=x_train,
trainY=y_train)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("trainXProvided", "trainX", "testX",
"feat_names", "max_num_clusts"))
testthat::expect_true(!is.na(res$trainXProvided))
testthat::expect_equal(length(res$trainXProvided), 1)
testthat::expect_true(is.logical(res$trainXProvided))
testthat::expect_true(res$trainXProvided)
testthat::expect_true(all(!is.na(res$trainX)))
testthat::expect_true(is.matrix(res$trainX))
testthat::expect_true(is.numeric(res$trainX))
testthat::expect_equal(nrow(res$trainX), 8)
testthat::expect_equal(ncol(res$trainX), 6)
testthat::expect_true(all(abs(x_train - res$trainX) < 10^(-9)))
testthat::expect_true(all(!is.na(res$testX)))
testthat::expect_true(is.matrix(res$testX))
testthat::expect_true(is.numeric(res$testX))
testthat::expect_equal(nrow(res$testX), 7)
testthat::expect_equal(ncol(res$testX), 6)
testthat::expect_true(all(abs(x_pred - res$testX) < 10^(-9)))
testthat::expect_true(is.character(res$feat_names))
testthat::expect_true(is.na(res$feat_names))
testthat::expect_true(is.na(res$max_num_clusts))
testthat::expect_true(length(res$max_num_clusts) == 1)
##### Try other bad inputs
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="weighted_avg",
cutoff=-0.5, min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"cutoff >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff="0.3", min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff=as.numeric(NA),
min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting=c("sparse",
"simple_avg"),
cutoff=0.1,
min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting=2, cutoff=0.1,
min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="spasre", cutoff=0.1,
min_num_clusts=1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse", cutoff=0.1,
min_num_clusts=c(1, 2),
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="weighted_avg",
cutoff=0.1, min_num_clusts="2",
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="simple_avg",
cutoff=0.1, min_num_clusts=-1,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="weighted_avg",
cutoff=0.1, min_num_clusts=10,
max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"min_num_clusts <= p is not TRUE", fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="simple_avg",
cutoff=0.1, min_num_clusts=1,
max_num_clusts="5",
trainX=x_train, trainY=y_train),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff=0.1, min_num_clusts=1,
max_num_clusts=4.5,
trainX=x_train, trainY=y_train),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff=0.1, min_num_clusts=3,
max_num_clusts=2,
trainX=x_train, trainY=y_train),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff=0.1, min_num_clusts=1,
max_num_clusts=10,
trainX=x_train, trainY=y_train),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B=10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- checkGetCssPredsInputs(css_res_train, testX=x_pred,
weighting="weighted_avg",
cutoff=0, min_num_clusts=1,
max_num_clusts=NA, trainX=x_train,
trainY=y_train)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("trainXProvided", "trainX", "testX",
"feat_names", "max_num_clusts"))
testthat::expect_true(!is.na(res$trainXProvided))
testthat::expect_equal(length(res$trainXProvided), 1)
testthat::expect_true(is.logical(res$trainXProvided))
testthat::expect_true(res$trainXProvided)
testthat::expect_true(all(!is.na(res$trainX)))
testthat::expect_true(is.matrix(res$trainX))
testthat::expect_true(is.numeric(res$trainX))
testthat::expect_equal(nrow(res$trainX), 8)
testthat::expect_equal(ncol(res$trainX), 6)
testthat::expect_true(all(abs(x_train - res$trainX) < 10^(-9)))
testthat::expect_true(all(!is.na(res$testX)))
testthat::expect_true(is.matrix(res$testX))
testthat::expect_true(is.numeric(res$testX))
testthat::expect_equal(nrow(res$testX), 7)
testthat::expect_equal(ncol(res$testX), 6)
testthat::expect_true(all(abs(x_pred - res$testX) < 10^(-9)))
testthat::expect_true(is.character(res$feat_names))
testthat::expect_true(is.na(res$feat_names))
testthat::expect_true(is.na(res$max_num_clusts))
testthat::expect_true(length(res$max_num_clusts) == 1)
# Things should still work if new x is not provided
res <- checkGetCssPredsInputs(css_res_train, testX=x_pred,
weighting="weighted_avg",
cutoff=0, min_num_clusts=1,
max_num_clusts=NA, trainX=NA, trainY=NA)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("trainXProvided", "trainX", "testX",
"feat_names", "max_num_clusts"))
testthat::expect_true(!is.na(res$trainXProvided))
testthat::expect_equal(length(res$trainXProvided), 1)
testthat::expect_true(is.logical(res$trainXProvided))
testthat::expect_true(!res$trainXProvided)
testthat::expect_true(all(!is.na(res$trainX)))
testthat::expect_true(is.matrix(res$trainX))
testthat::expect_true(is.numeric(res$trainX))
testthat::expect_equal(nrow(res$trainX), 5)
testthat::expect_equal(ncol(res$trainX), 6)
testthat::expect_true(all(abs(x_select[6:10, ] - res$trainX) < 10^(-9)))
testthat::expect_true(all(!is.na(res$testX)))
testthat::expect_true(is.matrix(res$testX))
testthat::expect_true(is.numeric(res$testX))
testthat::expect_equal(nrow(res$testX), 7)
testthat::expect_equal(ncol(res$testX), 6)
testthat::expect_true(all(abs(x_pred - res$testX) < 10^(-9)))
testthat::expect_true(is.character(res$feat_names))
testthat::expect_true(is.na(res$feat_names))
testthat::expect_true(is.na(res$max_num_clusts))
testthat::expect_true(length(res$max_num_clusts) == 1)
# Try not providing training indices and omitting newX--should get error
testthat::expect_error(checkGetCssPredsInputs(css_res, testX=x_pred,
weighting="sparse",
cutoff=0, min_num_clusts=1,
max_num_clusts=NA, trainX=NA, trainY=NA),
"css was not provided with indices to set aside for model training (train_inds), so must provide new X in order to generate a design matrix", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:6]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(checkGetCssPredsInputs(css_res_named, testX=x_pred,
weighting="simple_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_train) <- LETTERS[2:7]
colnames(x_pred) <- LETTERS[1:6]
testthat::expect_error(checkGetCssPredsInputs(css_res_named, testX=x_pred,
weighting="weighted_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_train) <- LETTERS[1:6]
colnames(x_pred) <- LETTERS[2:7]
testthat::expect_error(checkGetCssPredsInputs(css_res_named, testX=x_pred,
weighting="sparse", cutoff=0,
min_num_clusts=1, max_num_clusts=NA,
trainX=x_train, trainY=y_train),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_pred) <- LETTERS[1:6]
res_named <- checkGetCssPredsInputs(css_res_named, testX=x_pred,
weighting="simple_avg", cutoff=0,
min_num_clusts=1, max_num_clusts=NA,
trainX=x_train, trainY=y_train)
testthat::expect_true(is.list(res_named))
testthat::expect_identical(names(res_named), c("trainXProvided", "trainX", "testX",
"feat_names", "max_num_clusts"))
testthat::expect_true(all(!is.na(res_named$trainX)))
testthat::expect_true(is.matrix(res_named$trainX))
testthat::expect_true(is.numeric(res_named$trainX))
testthat::expect_equal(nrow(res_named$trainX), 8)
testthat::expect_equal(ncol(res_named$trainX), 6)
testthat::expect_true(all(abs(x_train - res_named$trainX) < 10^(-9)))
testthat::expect_true(is.character(res_named$feat_names))
testthat::expect_identical(res_named$feat_names, LETTERS[1:6])
# Try data.frame input to css and checkGetCssPredsInputs
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/3)
train_inds <- (max(selec_inds) + 1):(2*round(n/3))
test_inds <- setdiff(1:n, c(selec_inds, train_inds))
css_res_df <- css(X=X_df[c(selec_inds, train_inds), ],
y=y[c(selec_inds, train_inds)], lambda=0.01, B = 10,
train_inds=train_inds)
res_df <- checkGetCssPredsInputs(css_res_df, testX=X_df[test_inds, ],
weighting="sparse", cutoff=0,
min_num_clusts=1, max_num_clusts=NA,
trainX=NA, trainY=NA)
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("trainXProvided", "trainX",
"testX","feat_names",
"max_num_clusts"))
testthat::expect_true(all(!is.na(res_df$trainX)))
testthat::expect_true(is.matrix(res_df$trainX))
testthat::expect_true(is.numeric(res_df$trainX))
testthat::expect_equal(nrow(res_df$trainX), length(train_inds))
stopifnot(nrow(css_res_df$X) >= max(train_inds))
train_mat <- css_res_df$X[train_inds, ]
testthat::expect_equal(ncol(res_df$trainX), ncol(train_mat))
testthat::expect_true(all(abs(train_mat - res_df$trainX) < 10^(-9)))
testthat::expect_identical(colnames(res_df$trainX), colnames(train_mat))
testthat::expect_true(all(!is.na(res_df$testX)))
testthat::expect_true(is.matrix(res_df$testX))
testthat::expect_true(is.numeric(res_df$testX))
testthat::expect_equal(nrow(res_df$testX), length(test_inds))
test_mat <- stats::model.matrix(~ ., X_df[test_inds, ])
test_mat <- test_mat[, colnames(test_mat) != "(Intercept)"]
testthat::expect_equal(ncol(res_df$testX), ncol(test_mat))
testthat::expect_true(all(abs(test_mat - res_df$testX) < 10^(-9)))
testthat::expect_identical(colnames(res_df$testX), colnames(test_mat))
testthat::expect_identical(colnames(res_df$testX), colnames(res_df$trainX))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
res_df <- checkGetCssPredsInputs(css_res_df, testX=X_df[test_inds, ],
weighting="simple_avg", cutoff=0.3,
min_num_clusts=1, max_num_clusts=4,
trainX=X_df[train_inds, ],
trainY=y[train_inds])
testthat::expect_true(is.list(res_df))
testthat::expect_identical(names(res_df), c("trainXProvided", "trainX",
"testX","feat_names",
"max_num_clusts"))
testthat::expect_true(all(!is.na(res_df$trainX)))
testthat::expect_true(is.matrix(res_df$trainX))
testthat::expect_true(is.numeric(res_df$trainX))
testthat::expect_equal(nrow(res_df$trainX), length(train_inds))
train_mat <- stats::model.matrix(~ ., X_df[train_inds, ])
train_mat <- train_mat[, colnames(train_mat) != "(Intercept)"]
testthat::expect_equal(ncol(res_df$trainX), ncol(train_mat))
testthat::expect_true(all(abs(train_mat - res_df$trainX) < 10^(-9)))
testthat::expect_true(all(!is.na(res_df$testX)))
testthat::expect_true(is.matrix(res_df$testX))
testthat::expect_true(is.numeric(res_df$testX))
testthat::expect_equal(nrow(res_df$testX), length(test_inds))
test_mat <- stats::model.matrix(~ ., X_df[test_inds, ])
test_mat <- test_mat[, colnames(test_mat) != "(Intercept)"]
testthat::expect_equal(ncol(res_df$testX), ncol(test_mat))
testthat::expect_true(all(abs(test_mat - res_df$testX) < 10^(-9)))
})## -- Warning: checkGetCssPredsInputs works ---------------------------------------
## New X provided had no variable names (column names) even though the X provided to css did.
## Backtrace:
## x
## 1. +-testthat::expect_warning(...)
## 2. | \-testthat:::expect_condition_matching_(...)
## 3. | \-testthat:::quasi_capture(...)
## 4. | +-testthat (local) .capture(...)
## 5. | | \-base::withCallingHandlers(...)
## 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
## 7. \-litr (local) checkGetCssPredsInputs(...)
## 8. \-litr (local) checkXInputResults(testX, css_results$X)
## Test passed with 125 successes.Finally, tests for getCssPreds()
testthat::test_that("getCssPreds works", {
set.seed(70811)
x_select <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
x_train <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
x_pred <- matrix(stats::rnorm(7*6), nrow=7, ncol=6)
y_select <- stats::rnorm(10)
y_train <- stats::rnorm(8)
good_clusters <- list("red"=1:2, "blue"=3:4, "green"=5)
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
res <- getCssPreds(css_res, testX=x_pred, trainX=x_train, trainY=y_train)
testthat::expect_true(all(!is.na(res)))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(length(res), 7)
# (#104, L6) The OLS adequacy guard must account for the lm() intercept. At the
# default cutoff the training design has one column per cluster; css_res has 4
# clusters (red, blue, green, and feature 6 as a singleton). With exactly 4
# training rows, lm(y ~ .) is rank-deficient (4 observations vs 4 cluster
# coefficients + an intercept), so getCssPreds must now error rather than
# silently fit a rank-deficient model with NA coefficients.
x_train_eq <- matrix(stats::rnorm(4*6), nrow=4, ncol=6)
y_train_eq <- stats::rnorm(4)
testthat::expect_error(
getCssPreds(css_res, testX=x_pred, trainX=x_train_eq, trainY=y_train_eq),
"one more training observation than the number of clusters", fixed=TRUE)
# One extra training row (5 observations vs 4 coefficients + intercept) is
# enough, and predictions are produced normally.
x_train_ok <- matrix(stats::rnorm(5*6), nrow=5, ncol=6)
y_train_ok <- stats::rnorm(5)
res_ok <- getCssPreds(css_res, testX=x_pred, trainX=x_train_ok,
trainY=y_train_ok)
testthat::expect_true(all(!is.na(res_ok)))
testthat::expect_equal(length(res_ok), 7)
# (#105, L9) The value-producing calls above only exercise the default
# weighting="weighted_avg"; cover "sparse" and "simple_avg" too on the
# trainX/trainY path. Each weighting must return a finite numeric vector of
# length nrow(x_pred).
preds_by_w <- list()
for(w in c("weighted_avg", "sparse", "simple_avg")){
preds_w <- getCssPreds(css_res, testX=x_pred, weighting=w, trainX=x_train,
trainY=y_train)
testthat::expect_true(is.numeric(preds_w))
testthat::expect_true(all(!is.na(preds_w)))
testthat::expect_equal(length(preds_w), nrow(x_pred))
preds_by_w[[w]] <- preds_w
}
# getCssPreds already enforces finiteness internally, so "didn't error" is
# nearly vacuous; pin the behavior by requiring the three weightings to
# produce mutually different predictions.
testthat::expect_false(isTRUE(all.equal(preds_by_w[["weighted_avg"]],
preds_by_w[["sparse"]])))
testthat::expect_false(isTRUE(all.equal(preds_by_w[["weighted_avg"]],
preds_by_w[["simple_avg"]])))
testthat::expect_false(isTRUE(all.equal(preds_by_w[["sparse"]],
preds_by_w[["simple_avg"]])))
# (#105, L10a) trainY OLS-response contract. A non-numeric trainY is caught
# upstream by checkGetCssPredsInputs' stopifnot(is.numeric(trainY)) (which
# shadows getCssPreds' own "must be real-valued" guard -- that guard is dead
# code, flagged for a future cleanup), so the message is the stopifnot text.
testthat::expect_error(
getCssPreds(css_res, testX=x_pred, trainX=x_train,
trainY=factor(sample(letters[1:3], nrow(x_train),
replace=TRUE))),
"is.numeric(trainY) is not TRUE", fixed=TRUE)
##### Try other bad inputs
testthat::expect_error(getCssPreds(css_res, testX=x_pred, cutoff=-0.5,
trainX=x_train, trainY=y_train),
"cutoff >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, cutoff="0.3",
trainX=x_train, trainY=y_train),
"is.numeric(cutoff) | is.integer(cutoff) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred,
cutoff=as.numeric(NA), trainX=x_train,
trainY=y_train),
"!is.na(cutoff) is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred,
weighting=c("sparse", "simple_avg"),
trainX=x_train, trainY=y_train),
"length(weighting) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, weighting=2,
trainX=x_train, trainY=y_train),
"Weighting must be a character", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, weighting="spasre",
trainX=x_train, trainY=y_train),
"Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred,
min_num_clusts=c(1, 2), trainX=x_train,
trainY=y_train),
"length(min_num_clusts) == 1 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, min_num_clusts="2",
trainX=x_train, trainY=y_train),
"is.numeric(min_num_clusts) | is.integer(min_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, min_num_clusts=-1,
trainX=x_train, trainY=y_train),
"min_num_clusts >= 0 is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, min_num_clusts=10,
trainX=x_train, trainY=y_train),
"min_num_clusts <= p is not TRUE", fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, max_num_clusts="5",
trainX=x_train, trainY=y_train),
"is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, max_num_clusts=4.5,
trainX=x_train, trainY=y_train),
"max_num_clusts == round(max_num_clusts) is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, min_num_clusts=3,
max_num_clusts=2, trainX=x_train,
trainY=y_train),
"max_num_clusts >= min_num_clusts is not TRUE",
fixed=TRUE)
testthat::expect_error(getCssPreds(css_res, testX=x_pred, max_num_clusts=10,
trainX=x_train, trainY=y_train),
"max_num_clusts <= p is not TRUE", fixed=TRUE)
# Add training indices
css_res_train <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B=10, train_inds=6:10)
# Training indices should be ignored if new x is provided
res <- getCssPreds(css_res_train, testX=x_pred, trainX=x_train,
trainY=y_train)
testthat::expect_true(all(!is.na(res)))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(length(res), 7)
# Things should still work if new x is not provided
res <- getCssPreds(css_res_train, testX=x_pred)
testthat::expect_true(all(!is.na(res)))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(length(res), 7)
# (#105, L9) Same weighting coverage ("sparse"/"simple_avg" plus the default)
# on the train_inds (no-trainX) path, and the same mutual-difference pin.
preds_by_w_ti <- list()
for(w in c("weighted_avg", "sparse", "simple_avg")){
preds_w_ti <- getCssPreds(css_res_train, testX=x_pred, weighting=w)
testthat::expect_true(is.numeric(preds_w_ti))
testthat::expect_true(all(!is.na(preds_w_ti)))
testthat::expect_equal(length(preds_w_ti), nrow(x_pred))
preds_by_w_ti[[w]] <- preds_w_ti
}
testthat::expect_false(isTRUE(all.equal(preds_by_w_ti[["weighted_avg"]],
preds_by_w_ti[["sparse"]])))
testthat::expect_false(isTRUE(all.equal(preds_by_w_ti[["weighted_avg"]],
preds_by_w_ti[["simple_avg"]])))
testthat::expect_false(isTRUE(all.equal(preds_by_w_ti[["sparse"]],
preds_by_w_ti[["simple_avg"]])))
# Try not providing training indices and omitting newX--should get error
testthat::expect_error(getCssPreds(css_res, testX=x_pred),
"css was not provided with indices to set aside for model training (train_inds), so must provide new X in order to generate a design matrix", fixed=TRUE)
# Try naming variables
colnames(x_select) <- LETTERS[1:6]
css_res_named <- css(X=x_select, y=y_select, lambda=0.01,
clusters=good_clusters, B = 10)
# Named variables for css matrix but not new one--should get a warning
testthat::expect_warning(getCssPreds(css_res_named, testX=x_pred,
trainX=x_train, trainY=y_train),
"New X provided had no variable names (column names) even though the X provided to css did.", fixed=TRUE)
# Try mismatching variable names
colnames(x_train) <- LETTERS[2:7]
colnames(x_pred) <- LETTERS[1:6]
testthat::expect_error(getCssPreds(css_res_named, testX=x_pred,
trainX=x_train, trainY=y_train),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_train) <- LETTERS[1:6]
colnames(x_pred) <- LETTERS[2:7]
testthat::expect_error(getCssPreds(css_res_named, testX=x_pred,
trainX=x_train, trainY=y_train),
"Provided feature names for newx do not match feature names provided to css",
fixed=TRUE)
colnames(x_pred) <- LETTERS[1:6]
res_named <- getCssPreds(css_res_named, testX=x_pred, trainX=x_train,
trainY=y_train)
testthat::expect_true(all(!is.na(res)))
testthat::expect_true(is.numeric(res))
testthat::expect_equal(length(res), 7)
# Try data.frame input to css and getCssPreds
X_df <- datasets::mtcars
n <- nrow(X_df)
y <- stats::rnorm(n)
selec_inds <- 1:round(n/3)
# 18 (not 17) training rows: once the factor columns below are one-hot encoded
# the design has 17 cluster representatives, and the OLS adequacy guard (#104,
# L6) now requires strictly more training rows than clusters (the lm()
# intercept), so 17 == 17 would (correctly) error.
train_inds <- (max(selec_inds) + 1):(max(selec_inds) + 18)
test_inds <- setdiff(1:n, c(selec_inds, train_inds))
css_res_df <- css(X=X_df[c(selec_inds, train_inds), ],
y=y[c(selec_inds, train_inds)], lambda=0.01, B = 10,
train_inds=train_inds)
res_df <- getCssPreds(css_res_df, testX=X_df[test_inds, ])
testthat::expect_true(all(!is.na(res_df)))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(length(res_df), length(test_inds))
# Try again with X as a dataframe with factors (number of columns of final
# design matrix after one-hot encoding factors won't match number of columns
# of X_df)
X_df$cyl <- as.factor(X_df$cyl)
X_df$vs <- as.factor(X_df$vs)
X_df$am <- as.factor(X_df$am)
X_df$gear <- as.factor(X_df$gear)
X_df$carb <- as.factor(X_df$carb)
css_res_df <- css(X=X_df[selec_inds, ], y=y[selec_inds], lambda=0.01, B = 10)
# #142: this data.frame testX+trainX path used to emit two spurious column-name
# warnings -- checkNewXProvided strips trainX's names, so a named testX and a
# name-less trainX tripped "provided for testX but not for trainX" and, via
# formCssDesign(newx=trainX), "New X provided had no variable names". After the
# trainX re-attach in checkGetCssPredsInputs, NEITHER fires. Capture warnings
# and assert both #142 messages are absent.
df_warns <- character(0)
res_df <- withCallingHandlers(
getCssPreds(css_res_df, testX=X_df[test_inds, ],
trainX=X_df[train_inds, ], trainY=y[train_inds]),
warning=function(w){
df_warns <<- c(df_warns, conditionMessage(w))
invokeRestart("muffleWarning")
})
testthat::expect_false(any(grepl("testX but not for trainX", df_warns,
fixed=TRUE)))
testthat::expect_false(any(grepl("New X provided had no variable names",
df_warns, fixed=TRUE)))
testthat::expect_true(all(!is.na(res_df)))
testthat::expect_true(is.numeric(res_df))
testthat::expect_equal(length(res_df), length(test_inds))
# (#105, L10b) Reachable real-valued-y guard on the train_inds (no-trainX)
# path: when css was fit on a non-real-valued y (here a character response,
# which css accepts because validation is delegated to fitfun), getCssPreds
# cannot fit the OLS model from css_results$y[train_inds] and must error. The
# custom fitfun's formals must match cssLasso's (X, y, lambda) exactly. Seeded
# last so this RNG-consuming css() call does not shift any earlier draws.
set.seed(10510)
n_chr <- 12
X_chr <- matrix(stats::rnorm(n_chr*6), nrow=n_chr, ncol=6)
y_chr <- as.character(sample(letters, n_chr, replace=TRUE))
fitfun_chr <- function(X, y, lambda) 1:2
css_res_chr <- css(X_chr, y_chr, lambda=0.01, train_inds=8:12,
fitfun=fitfun_chr, B=10)
testthat::expect_error(
getCssPreds(css_res_chr, testX=matrix(stats::rnorm(3*6), nrow=3, ncol=6)),
"Can't generate predictions from the data", fixed=TRUE)
})## -- Warning: getCssPreds works --------------------------------------------------
## New X provided had no variable names (column names) even though the X provided to css did.
## Backtrace:
## x
## 1. +-testthat::expect_warning(...)
## 2. | \-testthat:::expect_condition_matching_(...)
## 3. | \-testthat:::quasi_capture(...)
## 4. | +-testthat (local) .capture(...)
## 5. | | \-base::withCallingHandlers(...)
## 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
## 7. \-litr (local) getCssPreds(...)
## 8. \-litr (local) checkGetCssPredsInputs(...)
## 9. \-litr (local) checkXInputResults(testX, css_results$X)
## Test passed with 67 successes.getCssPreds() accepts data.frame testX/trainX as well as matrices. When both
are data.frames with consistent columns, the predictions must be byte-identical to
the equivalent matrix inputs, and no spurious column-name warnings may be emitted
(#142). Because checkNewXProvided() strips trainX’s coerced names while
checkGetCssPredsInputs() re-attaches testX’s, a named testX used to pair with
a name-less trainX and trip two warnings even for consistent data.frames.
testthat::test_that("getCssPreds data.frame path is warning-free and matches matrix path (#142)", {
set.seed(14200)
p <- 5
Xm_select <- matrix(stats::rnorm(24 * p), nrow=24, ncol=p)
colnames(Xm_select) <- paste0("V", 1:p)
y_select <- stats::rnorm(24)
Xm_train <- matrix(stats::rnorm(10 * p), nrow=10, ncol=p)
colnames(Xm_train) <- paste0("V", 1:p)
y_train <- stats::rnorm(10)
Xm_test <- matrix(stats::rnorm(6 * p), nrow=6, ncol=p)
colnames(Xm_test) <- paste0("V", 1:p)
# Four clusters over five features; at the default cutoff the OLS design has at
# most four cluster representatives, and 10 training rows > 4 clears the
# lm()-intercept adequacy guard so predictions are produced (rather than
# hitting the OLS-size stop).
clusters <- list(a=1:2, b=3, c=4, d=5)
css_res <- css(X=Xm_select, y=y_select, lambda=0.01, clusters=clusters, B=10)
Xd_train <- as.data.frame(Xm_train)
Xd_test <- as.data.frame(Xm_test)
# (a) The data.frame testX+trainX path emits NEITHER #142 warning -- and, for a
# clean numeric data.frame with consistent names, no warning at all.
df_warns <- character(0)
preds_df <- withCallingHandlers(
getCssPreds(css_res, testX=Xd_test, trainX=Xd_train, trainY=y_train),
warning=function(w){
df_warns <<- c(df_warns, conditionMessage(w))
invokeRestart("muffleWarning")
})
testthat::expect_false(any(grepl("testX but not for trainX", df_warns,
fixed=TRUE)))
testthat::expect_false(any(grepl("New X provided had no variable names",
df_warns, fixed=TRUE)))
testthat::expect_length(df_warns, 0)
# (c) Byte-identity: column names never enter the numeric path (formCssDesign
# strips them and forms cluster representatives positionally), so the
# data.frame-input predictions equal the matrix-input predictions exactly.
preds_mat <- getCssPreds(css_res, testX=Xm_test, trainX=Xm_train,
trainY=y_train)
testthat::expect_equal(unname(preds_df), unname(preds_mat))
# (b) A genuine column-name mismatch must still error -- the re-attach uses the
# already-validated feat_names and cannot mask a real mismatch: a trainX
# data.frame whose names differ from the X css was fit on is rejected.
Xd_train_bad <- Xd_train
colnames(Xd_train_bad) <- paste0("W", 1:p)
testthat::expect_error(
getCssPreds(css_res, testX=Xd_test, trainX=Xd_train_bad, trainY=y_train),
"Provided feature names for newx do not match feature names provided to css", fixed=TRUE)
})## Test passed with 5 successes.A cluster named after the response variable ("y") is legal (checkClusters
allows any cluster name), but getCssPreds() built its OLS design as
data.frame(y = y_train, ...) and then restored the cluster names, yielding two
columns named y; lm(y ~ .) then silently dropped the cluster representative
from the right-hand side and returned wrong (or, if the "y"-named cluster was
the only selected cluster, intercept-only) predictions. Predictions must be
invariant to cluster names, through both getCssPreds() and its cssPredict()
wrapper (#150).
testthat::test_that("getCssPreds/cssPredict: a cluster named 'y' does not corrupt predictions (#150)", {
set.seed(42)
n <- 100
p <- 6
X <- matrix(stats::rnorm(n * p), n, p)
y <- rowMeans(X[, 1:3]) * 3 + stats::rnorm(n) # signal in cluster 1:3
run_preds <- function(cl_name) {
res <- css(
X[1:60, ], y[1:60], lambda = 0.05,
clusters = stats::setNames(list(1:3), cl_name), B = 10
)
getCssPreds(
res, testX = X[61:80, ], trainX = X[81:100, ],
trainY = y[81:100], max_num_clusts = 3
)
}
set.seed(7)
preds_y <- run_preds("y") # cluster named after the response
set.seed(7)
preds_ok <- run_preds("sig") # identical data/RNG, innocuous name
# The cluster name must not affect predictions.
testthat::expect_equal(preds_y, preds_ok)
# Same guarantee via the cssPredict() entry point.
run_cssPredict <- function(cl_name) {
cssPredict(
X_train_selec = X[1:60, ], y_train_selec = y[1:60],
X_test = X[61:80, ],
clusters = stats::setNames(list(1:3), cl_name),
lambda = 0.05, max_num_clusts = 3
)
}
set.seed(7)
cp_y <- run_cssPredict("y")
set.seed(7)
cp_ok <- run_cssPredict("sig")
testthat::expect_equal(cp_y, cp_ok)
})## Test passed with 2 successes.The three partial-training-input branches of checkGetCssPredsInputs() – the
hard stop when trainX is supplied without trainY and css had no
train_inds, and the two fallback warnings when only one of trainX/trainY
is supplied alongside train_inds – are otherwise unexercised (#128).
testthat::test_that("getCssPreds handles partial trainX/trainY inputs (#128)", {
set.seed(128)
X <- matrix(stats::rnorm(15 * 6), nrow = 15, ncol = 6)
y <- stats::rnorm(15)
# 1:3 as one cluster; feats 4, 5, 6 become singletons -> 4 clusters total.
clusters <- list(cluster1 = 1:3)
# No train_inds (train_inds empty).
css_no_train <- css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10)
# train_inds length 6 > 4 clusters, so the fallback path clears the downstream
# OLS-size guard (needs more training rows than clusters) and can predict
# rather than error.
css_with_train <- css(X = X, y = y, lambda = 0.01, clusters = clusters,
B = 10, train_inds = 10:15)
testX <- matrix(stats::rnorm(4 * 6), nrow = 4, ncol = 6)
trainX <- matrix(stats::rnorm(8 * 6), nrow = 8, ncol = 6)
# (A) trainX provided, trainY missing (scalar NA), css had NO train_inds ->
# hard stop.
testthat::expect_error(
getCssPreds(css_no_train, testX = testX, trainX = trainX, trainY = NA),
"must provide both trainX and trainY", fixed = TRUE)
# (B) trainX provided, trainY missing, css HAD train_inds -> warn, fall back to
# the train_inds observations, then predict.
testthat::expect_warning(
getCssPreds(css_with_train, testX = testX, trainX = trainX, trainY = NA),
"trainX provided but no trainY", fixed = TRUE)
# (C) trainY provided but no trainX, css HAD train_inds -> warn, use the
# train_inds observations (trainY is ignored on this path), then predict.
testthat::expect_warning(
getCssPreds(css_with_train, testX = testX, trainY = c(1, 2, 3)),
"trainY provided but no trainX", fixed = TRUE)
})## -- Warning: getCssPreds handles partial trainX/trainY inputs (#128) ------------
## from glmnet C++ code (error code -80); Convergence for 80th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned
## Backtrace:
## x
## 1. \-litr (local) css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10)
## 2. \-litr (local) getSelMatrix(...)
## Test passed with 3 successes.The prediction-path input checks emit one warning per genuinely-ambiguous input, and never a spurious or duplicated one (issue #153, items a–c). trainX keeps its own validated names (restored from the css object, not from testX), the design validation runs once rather than up to four times per call, and the trainX/testX name-asymmetry warnings are both live and correctly directional.
testthat::test_that("getCssPreds: named trainX + unnamed testX warns only about testX (#153a)", {
set.seed(153)
n <- 60; p <- 8
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
colnames(X) <- paste0("V", 1:p)
y <- X[, 1] + X[, 2] + stats::rnorm(n)
clusters <- list(c1 = 1:3)
res_ti <- css(X = X[1:40, ], y = y[1:40], lambda = 0.01, clusters = clusters,
B = 10, train_inds = 21:40)
trainX_named <- X[21:40, ]
testX_unnamed <- X[41:60, ]; colnames(testX_unnamed) <- NULL
trainY <- y[21:40]
ww <- character()
preds <- withCallingHandlers(
getCssPreds(res_ti, testX = testX_unnamed, trainX = trainX_named,
trainY = trainY),
warning = function(w){
ww <<- c(ww, conditionMessage(w)); invokeRestart("muffleWarning")
})
# A named trainX must NOT provoke a spurious "no variable names" warning about
# itself: exactly the two legitimate testX warnings fire (one per issue).
testthat::expect_length(ww, 2)
testthat::expect_equal(
sum(grepl("New X provided had no variable names", ww, fixed = TRUE)), 1)
testthat::expect_equal(
sum(grepl("Column names were provided for trainX but not for testX", ww,
fixed = TRUE)), 1)
testthat::expect_false(
any(grepl("Column names were provided for testX but not for trainX", ww,
fixed = TRUE)))
testthat::expect_true(is.numeric(preds))
})## Test passed with 5 successes.testthat::test_that("getCssPreds: unnamed trainX + unnamed testX warns once per matrix (#153b)", {
set.seed(153)
n <- 60; p <- 8
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
colnames(X) <- paste0("V", 1:p)
y <- X[, 1] + X[, 2] + stats::rnorm(n)
clusters <- list(c1 = 1:3)
res_ti <- css(X = X[1:40, ], y = y[1:40], lambda = 0.01, clusters = clusters,
B = 10, train_inds = 21:40)
trainX_unnamed <- X[21:40, ]; colnames(trainX_unnamed) <- NULL
testX_unnamed <- X[41:60, ]; colnames(testX_unnamed) <- NULL
trainY <- y[21:40]
ww <- character()
withCallingHandlers(
getCssPreds(res_ti, testX = testX_unnamed, trainX = trainX_unnamed,
trainY = trainY),
warning = function(w){
ww <<- c(ww, conditionMessage(w)); invokeRestart("muffleWarning")
})
# Down from 4 identical warnings (one per redundant re-validation) to exactly
# one per unnamed matrix.
testthat::expect_length(ww, 2)
testthat::expect_true(all(grepl("New X provided had no variable names", ww,
fixed = TRUE)))
# (b') default (train_inds) path + unnamed testX: no FALSE trainX asymmetry
# warning, and it still predicts.
ww2 <- character()
preds <- withCallingHandlers(
getCssPreds(res_ti, testX = testX_unnamed),
warning = function(w){
ww2 <<- c(ww2, conditionMessage(w)); invokeRestart("muffleWarning")
})
testthat::expect_false(
any(grepl("Column names were provided for trainX but not for testX", ww2,
fixed = TRUE)))
testthat::expect_true(is.numeric(preds))
testthat::expect_length(preds, 20)
})## Test passed with 5 successes.testthat::test_that("getCssPreds: unnamed trainX + named testX fires the testX asymmetry warning (#153c)", {
set.seed(153)
n <- 60; p <- 8
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
colnames(X) <- paste0("V", 1:p)
y <- X[, 1] + X[, 2] + stats::rnorm(n)
clusters <- list(c1 = 1:3)
res_ti <- css(X = X[1:40, ], y = y[1:40], lambda = 0.01, clusters = clusters,
B = 10, train_inds = 21:40)
trainX_unnamed <- X[21:40, ]; colnames(trainX_unnamed) <- NULL
testX_named <- X[41:60, ]
trainY <- y[21:40]
ww <- character()
withCallingHandlers(
getCssPreds(res_ti, testX = testX_named, trainX = trainX_unnamed,
trainY = trainY),
warning = function(w){
ww <<- c(ww, conditionMessage(w)); invokeRestart("muffleWarning")
})
# This asymmetry warning was previously dead: the old code always re-named
# trainX from testX, making its condition unsatisfiable.
testthat::expect_true(
any(grepl("Column names were provided for testX but not for trainX", ww,
fixed = TRUE)))
})## Test passed with 1 success.A trainY that is PROVIDED but invalid (contains NA) must error rather than be
silently reclassified as “not provided” and quietly switch the model to the
train_inds data (issue #153, item d).
testthat::test_that("getCssPreds: a provided-but-NA trainY errors, never silently switches data (#153d)", {
set.seed(153)
n <- 60; p <- 8
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
colnames(X) <- paste0("V", 1:p)
y <- X[, 1] + X[, 2] + stats::rnorm(n)
clusters <- list(c1 = 1:3)
res_ti <- css(X = X[1:40, ], y = y[1:40], lambda = 0.01, clusters = clusters,
B = 10, train_inds = 21:40)
res_noti <- css(X = X[1:20, ], y = y[1:20], lambda = 0.01, clusters = clusters,
B = 10)
trainX_named <- X[21:40, ]
testX_named <- X[41:60, ]
trainY <- y[21:40]
trainY_na <- trainY; trainY_na[5] <- NA
# With train_inds available: must ERROR on the NA rather than silently fall
# back to the train_inds data (the old silent-swap + false "no trainY" warning).
testthat::expect_error(
getCssPreds(res_ti, testX = testX_named, trainX = trainX_named,
trainY = trainY_na),
"contains missing (NA)", fixed = TRUE)
# Without train_inds: the SAME NA error, not the misleading "must provide both".
testthat::expect_error(
getCssPreds(res_noti, testX = testX_named, trainX = trainX_named,
trainY = trainY_na),
"contains missing (NA)", fixed = TRUE)
# A valid trainX + trainY still predicts (no regression).
preds <- getCssPreds(res_ti, testX = testX_named, trainX = trainX_named,
trainY = trainY)
testthat::expect_true(is.numeric(preds))
testthat::expect_length(preds, 20)
})## Test passed with 4 successes.A focused test for the internal OLS-prediction helper olsPredictRankSafe()
(issue #117), which keeps getCssPreds() from crashing on a rank-deficient OLS
fit under R >= 4.4’s stats::predict.lm() default.
testthat::test_that("olsPredictRankSafe predicts from rank-deficient OLS without crashing (#117)", {
# (a) Crash/finiteness guard. On R >= 4.4 predict.lm()'s default
# rankdeficient="warnif" aborts ("NA/NaN/Inf in foreign function call") when
# qr.R(model$qr) holds NaN/Inf -- a rank-deficient fit plus a LINPACK numerical
# pathology seen on real high-dimensional data. Reproduce that precondition by
# fitting a rank-deficient lm (a duplicated column) and injecting NaN into an
# OFF-DIAGONAL upper-triangular entry of the aliased column. (The aliased
# diagonal entry alone does not reproduce it: predict.lm overwrites diagonal
# entries in rows beyond the rank with 1.)
set.seed(11711)
n_a <- 20
df_a <- data.frame(y=stats::rnorm(n_a), a=stats::rnorm(n_a),
b=stats::rnorm(n_a), c=stats::rnorm(n_a))
df_a$d <- df_a$b # duplicate column -> rank-deficient
model_a <- stats::lm(y ~ ., data=df_a)
R_a <- qr.R(model_a$qr)
aliased_col <- which.min(abs(diag(R_a))) # pivoted-last near-zero diagonal
testthat::expect_true(aliased_col > 1L)
model_a$qr$qr[1L, aliased_col] <- NaN # off-diagonal aliased entry
# Precondition (version-independent): qr.R now holds a non-finite value.
testthat::expect_true(any(!is.finite(qr.R(model_a$qr))))
newdata_a <- data.frame(a=stats::rnorm(5), b=stats::rnorm(5),
c=stats::rnorm(5), d=stats::rnorm(5))
testthat::skip_if(getRversion() < "4.4.0")
# Pre-fix path (default predict.lm) genuinely crashes on this model.
testthat::expect_error(stats::predict.lm(model_a, newdata=newdata_a))
# The helper returns a finite numeric vector of the right length...
preds_a <- olsPredictRankSafe(model_a, newdata_a)
testthat::expect_true(all(is.finite(preds_a)))
testthat::expect_equal(length(preds_a), nrow(newdata_a))
# ...and does so without surfacing the stock rank-deficient warning.
testthat::expect_no_warning(olsPredictRankSafe(model_a, newdata_a))
# (b) Warning muffle on a normal-scale rank-deficient design (duplicated
# column): predict.lm warns but does NOT crash. The helper must emit no
# "rank-deficient fit" warning and still return finite predictions.
set.seed(51422)
n_b <- 30
df_b <- data.frame(y=stats::rnorm(n_b), a=stats::rnorm(n_b),
b=stats::rnorm(n_b), c=stats::rnorm(n_b))
df_b$d <- df_b$b
model_b <- stats::lm(y ~ ., data=df_b)
newdata_b <- data.frame(a=stats::rnorm(6), b=stats::rnorm(6),
c=stats::rnorm(6), d=stats::rnorm(6))
# Sanity: the stock default warns on this design (confirms the muffle is real).
testthat::expect_warning(stats::predict.lm(model_b, newdata=newdata_b),
"rank-deficient fit")
testthat::expect_no_warning(preds_b <- olsPredictRankSafe(model_b,
newdata_b))
testthat::expect_true(all(is.finite(preds_b)))
testthat::expect_equal(length(preds_b), nrow(newdata_b))
})## Test passed with 10 successes.A cross-cutting integration test pinning the bug fixed in #99: a single
non-finite (Inf) cell used to slip silently through checkNoNAs()
(is.na(Inf) is FALSE) into glmnet and the cluster-representative averaging
– corrupting selection proportions and predictions with no error. Both the
css() selection path and the getCssPreds() prediction path must now error at
the gate.
testthat::test_that("css and getCssPreds reject non-finite (Inf) inputs (#99)", {
set.seed(99001)
X <- matrix(stats::rnorm(10 * 6), nrow = 10, ncol = 6)
y <- stats::rnorm(10)
good_clusters <- list("red" = 1:2, "blue" = 3:4, "green" = 5)
# One Inf cell in the css design matrix now errors (previously: silent
# corruption of the selection proportions).
X_inf <- X
X_inf[3, 2] <- Inf
testthat::expect_error(
css(X = X_inf, y = y, lambda = 0.01, clusters = good_clusters, B = 10),
"must not contain missing", fixed = TRUE)
# A valid css fit; then an Inf in testX passed to getCssPreds must error too.
# testX is gated via checkGetCssPredsInputs -> checkXInputResults(testX) ->
# checkNoNAs(newx, "newx"), so the message names "newx", not "testX"; assert
# the stable non-finite substring instead.
css_res <- css(X = X, y = y, lambda = 0.01, clusters = good_clusters, B = 10)
x_train <- matrix(stats::rnorm(8 * 6), nrow = 8, ncol = 6)
y_train <- stats::rnorm(8)
x_pred <- matrix(stats::rnorm(7 * 6), nrow = 7, ncol = 6)
# Sanity: clean inputs still predict finite values.
preds_ok <- getCssPreds(css_res, testX = x_pred, trainX = x_train,
trainY = y_train)
testthat::expect_true(all(is.finite(preds_ok)))
x_pred_inf <- x_pred
x_pred_inf[1, 1] <- Inf
testthat::expect_error(
getCssPreds(css_res, testX = x_pred_inf, trainX = x_train,
trainY = y_train),
"must not contain missing", fixed = TRUE)
})## Test passed with 3 successes.The lasso entry points reject non-finite y (#100). Companion to the #99 test
above (which guards X):
testthat::test_that("the lasso entry points reject non-finite y (#100)", {
set.seed(100001)
X <- matrix(stats::rnorm(15 * 6), nrow = 15, ncol = 6)
y <- stats::rnorm(15)
good_clusters <- list("red" = 1:3, "green" = 4:6)
test_X <- matrix(stats::rnorm(7 * 6), nrow = 7, ncol = 6)
y_na <- y; y_na[4] <- NA
y_inf <- y; y_inf[9] <- Inf
# --- getLassoLambda nondeterminism pin -------------------------------------
# getLassoLambda fits cv.glmnet on a RANDOM subsample (sample(1:n, ...)), so
# before this fix a non-finite y in a single cell errored only on the draws
# that happened to include it. checkFiniteY runs BEFORE that sample(), so it
# must now error under EVERY seed -- never returning a stray lambda.
for(s in c(1L, 2L, 7L, 13L, 101L, 2024L)){
set.seed(s)
testthat::expect_error(getLassoLambda(X = X, y = y_na, nfolds = 4),
"must not contain missing", fixed = TRUE)
set.seed(s)
testthat::expect_error(getLassoLambda(X = X, y = y_inf, nfolds = 4),
"must not contain missing", fixed = TRUE)
}
# A clean y still returns a valid lambda (no success -> error regression).
set.seed(100002)
lam_ok <- getLassoLambda(X = X, y = y, nfolds = 4)
testthat::expect_true(is.numeric(lam_ok) && length(lam_ok) == 1 &&
!is.na(lam_ok) && lam_ok >= 0)
# --- entry-point integration ----------------------------------------------
testthat::expect_error(cssSelect(X = X, y = y_na),
"must not contain missing", fixed = TRUE)
testthat::expect_error(cssPredict(X_train_selec = X, y_train_selec = y_na,
X_test = test_X),
"must not contain missing", fixed = TRUE)
testthat::expect_error(getModelSize(X = X, y = y_inf, clusters = good_clusters),
"must not contain missing", fixed = TRUE)
# protolasso / clusterRepLasso route through processClusterLassoInputs, whose
# stopifnot(all(is.finite(y))) now catches Inf (previously all(!is.na(y))).
testthat::expect_error(protolasso(X = X, y = y_inf, clusters = good_clusters),
"is.finite", fixed = TRUE)
testthat::expect_error(clusterRepLasso(X = X, y = y_inf,
clusters = good_clusters),
"is.finite", fixed = TRUE)
# css()'s default cssLasso path validates each random subsample via
# checkCssLassoInputs. A single non-finite cell would fire only on the
# subsamples that draw it; set enough Inf cells (> n - floor(n/2)) that EVERY
# size-floor(n/2) subsample must contain one, so css errors deterministically.
y_many_inf <- y; y_many_inf[1:9] <- Inf
testthat::expect_error(
css(X = X, y = y_many_inf, lambda = 0.01, clusters = good_clusters, B = 10),
"non-finite", fixed = TRUE)
# Clean finite y still selects without error.
res_ok <- cssSelect(X = X, y = y, clusters = good_clusters)
testthat::expect_true(is.list(res_ok))
})## -- Warning: the lasso entry points reject non-finite y (#100) ------------------
## Option grouped=FALSE enforced in cv.glmnet, since < 3 observations per fold
## Backtrace:
## x
## 1. \-litr (local) getLassoLambda(X = X, y = y, nfolds = 4)
## 2. \-glmnet::cv.glmnet(...)
## 3. \-glmnet:::cv.glmnet.raw(...)
## -- Warning: the lasso entry points reject non-finite y (#100) ------------------
## Option grouped=FALSE enforced in cv.glmnet, since < 3 observations per fold
## Backtrace:
## x
## 1. \-litr (local) cssSelect(X = X, y = y, clusters = good_clusters)
## 2. \-litr (local) getLassoLambda(X, y, alpha = alpha)
## 3. \-glmnet::cv.glmnet(...)
## 4. \-glmnet:::cv.glmnet.raw(...)
## -- Warning: the lasso entry points reject non-finite y (#100) ------------------
## Option grouped=FALSE enforced in cv.glmnet, since < 3 observations per fold
## Backtrace:
## x
## 1. \-litr (local) cssSelect(X = X, y = y, clusters = good_clusters)
## 2. \-litr (local) getModelSize(X, y, css_results$clusters, alpha = alpha)
## 3. \-glmnet::cv.glmnet(x = X_size, y = y, family = "gaussian", alpha = alpha)
## 4. \-glmnet:::cv.glmnet.raw(...)
## Test passed with 20 successes.