"sparse" — concentrate the weight on the most-selected
+member, in the spirit of the protolasso. Simplest, but discards the rest
+of the cluster. On a tie the members at the top selection proportion
+share the weight equally, so that cluster’s column is their average
+rather than a copy of one member.
for (w in c("simple_avg", "weighted_avg", "sparse")) {
diff --git a/docs/articles/prediction.md b/docs/articles/prediction.md
index e783d501..d9169b31 100644
--- a/docs/articles/prediction.md
+++ b/docs/articles/prediction.md
@@ -104,8 +104,11 @@ formed:
- `"weighted_avg"` — a weighted average with weights inferred from the
selection proportions, so noisier proxies get less weight. Best when
the members’ noise levels vary.
-- `"sparse"` — use a single member (the most-selected one), in the
- spirit of the protolasso. Simplest, but discards the other members.
+- `"sparse"` — concentrate the weight on the most-selected member, in
+ the spirit of the protolasso. Simplest, but discards the rest of the
+ cluster. On a tie the members at the top selection proportion share
+ the weight equally, so that cluster’s column is their average rather
+ than a copy of one member.
``` r
for (w in c("simple_avg", "weighted_avg", "sparse")) {
diff --git a/docs/create/404.html b/docs/create/404.html
index 98ccb272..b6ea20ad 100644
--- a/docs/create/404.html
+++ b/docs/create/404.html
@@ -23,7 +23,7 @@
-
+
diff --git a/docs/create/competitor-methods.html b/docs/create/competitor-methods.html
index b23dd4cd..81701bc7 100644
--- a/docs/create/competitor-methods.html
+++ b/docs/create/competitor-methods.html
@@ -12,7 +12,7 @@
-
+
diff --git a/docs/create/css.html b/docs/create/css.html
index d9bc321a..54b03e8c 100644
--- a/docs/create/css.html
+++ b/docs/create/css.html
@@ -12,7 +12,7 @@
-
+
diff --git a/docs/create/documenting-the-package-and-adding-readme-and-pkgdown-website.html b/docs/create/documenting-the-package-and-adding-readme-and-pkgdown-website.html
index e96fe0e0..4ca07b97 100644
--- a/docs/create/documenting-the-package-and-adding-readme-and-pkgdown-website.html
+++ b/docs/create/documenting-the-package-and-adding-readme-and-pkgdown-website.html
@@ -12,7 +12,7 @@
-
+
diff --git a/docs/create/index.html b/docs/create/index.html
index d3efe15d..48b31eca 100644
--- a/docs/create/index.html
+++ b/docs/create/index.html
@@ -12,7 +12,7 @@
-
+
@@ -167,7 +167,7 @@
Creating the cssr R package
-September 08, 2026
+September 10, 2026
diff --git a/docs/create/other-useful.html b/docs/create/other-useful.html
index 0d8ae927..5279ebdd 100644
--- a/docs/create/other-useful.html
+++ b/docs/create/other-useful.html
@@ -12,7 +12,7 @@
-
+
diff --git a/docs/create/overview.html b/docs/create/overview.html
index 99fc9578..5bb1f30b 100644
--- a/docs/create/overview.html
+++ b/docs/create/overview.html
@@ -12,7 +12,7 @@
-
+
diff --git a/docs/create/search_index.json b/docs/create/search_index.json
index fbf13146..b4324eb5 100644
--- a/docs/create/search_index.json
+++ b/docs/create/search_index.json
@@ -1 +1 @@
-[["index.html", "Creating the cssr R package 1 Introduction", " Creating the cssr R package Gregory Faletto September 08, 2026 1 Introduction Cluster stability selection is a feature selection method designed to allow stability selection to work effectively in the presence of highly correlated features. It was proposed in this paper: ###"faletto2022"### #' Faletto, G., & Bien, J. (2022). Cluster Stability Selection. #' \\emph{arXiv preprint arXiv:2201.00494}. #' \\url{https://arxiv.org/abs/2201.00494}. This bookdown uses literate programming to define the cssr R package, which implements the procedures described in the paper. For a light introduction demonstrating how to use cssr, please see the package’s website here. "],["overview.html", "2 Overview 2.1 Background 2.2 Outline 2.3 Package setup", " 2 Overview 2.1 Background 2.1.1 Complementary pairs stability selection The following paper introduces complementary pairs subsampling: ###"shah2013"### #' Shah, R. D., & Samworth, R. J. #' (2013). Variable selection with error control: Another look at stability #' selection. \\emph{Journal of the Royal Statistical Society. Series B: #' Statistical Methodology}, 75(1), 55–80. #' \\url{https://doi.org/10.1111/j.1467-9868.2011.01034.x}. Subsamples \\(A_1, \\ldots, A_B \\subset [n]\\) of size \\(\\lfloor n/2 \\rfloor\\) are drawn, as well as subsamples \\(\\overline{A}_b \\subset [n]\\) of the same size with \\(A_b \\cap \\overline{A}_b = \\emptyset\\). Our function getSubsamps() implements this subsampling. Writing \\(\\hat{S}^\\lambda(A)\\) for the selected features from applying a variable selection procedure with tuning parameter \\(\\lambda\\) on the data in a subset \\(A\\subset[n]\\), Shah and Samworth suggest computing the following: \\[ \\hat{\\Pi}_B^{\\text{(SS)}}(j) = \\frac{1}{2B} \\sum_{b=1}^B \\left[1\\left\\{j \\in \\hat{S}^\\lambda \\left( A_b \\right)\\right\\} + 1\\left\\{j \\in \\hat{S}^\\lambda (\\overline{A}_b)\\right\\} \\right]. \\] 2.1.2 Cluster stability selection We compute the proportion of the time that a feature \\(j \\in [p]\\) is selected for at least one \\(\\lambda \\in \\Lambda\\): \\[ \\hat{\\Pi}_B(j) := \\frac{1}{2B} \\sum_{b=1}^B \\left[ 1\\left\\{ j \\in \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^\\lambda \\left( A_b \\right) \\right\\} + 1\\left\\{ j \\in \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^\\lambda (\\overline{A}_b)\\right\\} \\right]. \\] We also compute a similar quantity at the level of clusters: For every cluster \\(C_k\\), we calculate the proportion of the time that at least one feature from \\(C_k\\) is selected for at least one \\(\\lambda \\in \\Lambda\\): \\[ \\hat{\\Theta}_B(C_k) := \\frac{1}{2B} \\sum_{b=1}^B \\left[ 1 \\left\\{ C_k \\cap \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^{\\lambda}\\left(A_b \\right) \\neq \\emptyset \\right\\} + 1 \\left\\{ C_k \\cap \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^{\\lambda}\\left(\\overline{A}_b \\right) \\neq \\emptyset \\right\\} \\right]. \\] We then calculate cluster representatives \\(\\boldsymbol{X}_{\\cdot C_k}^{\\text{rep}}\\) as weighted averages of the cluster members: \\[ \\boldsymbol{X}_{\\cdot C_k}^{\\text{rep}}:= \\sum_{j \\in C_k } w_{kj} \\boldsymbol{X}_{\\cdot j}. \\] We allow for several choices of weights: Weighted averaged cluster stability selection: \\[ w_{kj} = \\frac{\\hat{\\Pi}_B(j)}{\\sum_{j' \\in C_k} \\hat{\\Pi}_B(j')} \\qquad \\forall j \\in C_k . \\] Simple averaged cluster stability selection: \\[ w_{kj} = \\frac{1}{\\left| C_k \\right|} \\qquad \\forall j \\in C_k . \\] Sparse cluster stability selection: For each \\(j \\in C_k\\), \\[ w_{kj} = \\left. 1 \\left\\{ j \\in \\underset{j' \\in C_k}{\\arg \\max} \\left\\{ \\hat{\\Pi}_B(j') \\right\\} \\right\\} \\middle/ \\left| \\underset{j' \\in C_k}{\\arg \\max} \\left\\{ \\hat{\\Pi}_B(j') \\right\\} \\right| \\right. . \\] 2.2 Outline We will define the functions in this package in steps. First we define the workhorse function of the package, css(). This function takes as inputs a data set (\\(X\\), \\(y\\)), a feature selection method \\(\\hat S^\\lambda(\\cdot)\\), and clusters of features appearing in the data: \\(C_1,\\ldots,C_K\\). It calculates random subsamples of the data (\\(A_1,\\ldots, A_B\\) and \\(\\bar A_1,\\ldots, \\bar A_B\\)) and gets selected sets of features on each subsample (i.e., \\(\\hat S^\\lambda(A_b)\\) and \\(\\hat S^\\lambda(\\bar A_b)\\)). It returns a \\(2B\\times p\\) matrix of indicator variables for whether each feature was selected on each subsample (one row for each subsample, one column for each feature). It returns a similar \\(2B\\times K\\) matrix of indicator variables for whether any feature from each cluster was selected on each subsample. This is the most computationally intensive step of cluster stability selection, so it is isolated within its own function that is designed to be run only once on a data set. Next we define functions that take these indicator matrices and return useful output–for example, selected sets of features, or predictions on test data. These outputs depend on the selected features, which themselves depend on user-selected parameters (for example, the cutoff for selection proportions for selected clusters). Next, we define wrapper functions that compute all of the above in one step in a user-friendly way. (These functions are not recommended for large data sets or for “power users” who may want to call these functions multiple times on the same data set, because these wrapper functions make a new call to css() every time they are called, which is slow and computationally wasteful if the inputs to css() are not changed.) Finally, we define some other useful functions, like functions that generate clustered data to use for simulations or testing, or select a tuning parameter for the lasso via cross-validation. 2.3 Package setup Before proceeding to the actual functionality of the package, we start by specifying the information needed in the DESCRIPTION file of the R package. usethis::create_package( path = ".", fields = list( Package = params$package_name, Version = "0.4.7.9000", Title = "Cluster Stability Selection", Description = "Implementation of Cluster Stability Selection, a feature selection method proposed in Faletto and Bien (2022) <arXiv:2201.00494>.", Language = "en-US", URL = "https://gregfaletto.github.io/cssr-project/, https://github.com/gregfaletto/cssr-project", BugReports = "https://github.com/gregfaletto/cssr-project/issues", `Authors@R` = c(person( given = "Gregory", family = "Faletto", email = "gregory.faletto@marshall.usc.edu", role = c("aut", "cre", "cph") ), person( given = "Jacob", family = "Bien", email = "jbien@usc.edu", role = c("aut", "cph") )) ) ) usethis::use_mit_license(copyright_holder = "Gregory Faletto and Jacob Bien") We also define the package-level documentation that shows up when someone types package?cssr in the console: #' Cluster Stability Selection #' #' Cluster stability selection is a feature selection method designed to allow #' stability selection to work effectively in the presence of highly correlated #' features. It was proposed in <https://arxiv.org/abs/2201.00494>. To learn #' more about this package, please visit its website #' <https://gregfaletto.github.io/cssr-project/>. #' #' @docType package #' @seealso \\code{\\link{css}} \\code{\\link{cssSelect}} "],["css.html", "3 The core function: css 3.1 Main components of css 3.2 Helper functions", " 3 The core function: css The main inputs that css() accepts are the following: a design matrix X a response y a selection method fitfun with specified tuning parameter lambda. This specifies \\(\\hat{S}^\\lambda(A)\\). In particular: ###"param-fitfun"### #' @param fitfun A function; the feature selection function used on each #' subsample by cluster stability selection. This can be any feature selection #' method; the only requirement is that it accepts the arguments (and only the #' arguments) `X`, `y`, and `lambda` and returns an integer vector that is a #' subset of `1:p`. For example, `fitfun` could be best subset selection or #' forward stepwise selection or LARS and `lambda` could be the desired model #' size; or `fitfun` could be the elastic net and `lambda` could be a length-two #' vector specifying lambda and alpha. Default is `cssLasso`, an implementation #' of lasso (relying on the R package `glmnet`), where `lambda` must be a #' nonnegative numeric specifying the L1 penalty for the `lasso`, or a named #' length-2 vector `c(lambda, alpha)` for an elastic net fit (see `cssLasso`). and ###"param-lambda"### #' @param lambda A tuning parameter or set of tuning parameters that may be used #' by the feature selection method `fitfun`. In the default case when #' `fitfun = cssLasso`, lambda is a nonnegative numeric (or a named `c(lambda, alpha)` for an elastic net fit; see `cssLasso`): the penalty to use for each #' lasso fit. (`css()` does not require lambda to be any particular object because #' for a user-specified feature selection method `fitfun`, lambda can be an #' arbitrary object. See the description of `fitfun` below.) a specification of which features belong together in highly correlated clusters. This specifies the clusters \\(C_1,\\ldots, C_K\\). In particular: ###"param-clusters"### #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of `1:p`). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. If the same cluster is #' provided more than once, the duplicates will be removed, keeping only the #' first occurrence (and its name). Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). If #' clusters is a list of length 0 (or a list only containing clusters of length #' 1), then `css()` returns the same results as stability selection (so the #' returned `feat_sel_mat` will be identical to `clus_sel_mat`). Names for the #' clusters will be needed later; any clusters that are not given names in the #' provided list will be given names automatically by `css()`. CAUTION: if #' the provided X is a data.frame that contains a categorical feature with more #' than two levels, then the resulting matrix made from model.matrix will have a #' different number of columns than the provided data.frame, some of the feature #' numbers will change, and the clusters argument will not work properly (in the #' current version of the package). To get correct results in this case, please #' use model.matrix to convert the data.frame to a numeric matrix on your own, #' then provide this matrix and cluster assignments with respect to this matrix. #' Default is `list()` (so no clusters are specified). and a specification of the type of subsamples. For now we only consider the complementary subsets sampling of Shah and Samworth. However, we have included an option for Meinshausen-Buhlmann sampling which we may add later: ###"param-sampling_type"### #' @param sampling_type A character vector; either "SS" or "MB". For "MB", #' all B subsamples are drawn randomly (as proposed by Meinshausen and Bühlmann #' 2010). For "SS", in addition to these B subsamples, the B complementary pair #' subsamples will be drawn as well (see Faletto and Bien 2022 or Shah and #' Samworth 2013 for details). Default is "SS", and "MB" is not supported yet. The number of subsamples is also up to the user: ###"param-B"### #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. In this section, we will build the function css() step-by-step. First, css() creates random subsamples of the data: \\(A_1,\\ldots, A_B\\) (and \\(\\bar A_1,\\ldots, \\bar A_B\\) for Shah-Samworth subsampling). This is implemented in the function createSubsamples(). Next, css() executes the specified feature selection method \\(\\hat S^\\lambda(\\cdot)\\) on each subsample. This generates a binary matrix, feat_sel_mat, with one row for each subsample and one column for each feature in X. In each row, the entry corresponding to each feature equals 1 if the feature was selected on that subsample and 0 otherwise. feat_sel_mat is one of the outputs of css(); it is used to calculate the selection proportions for individual features. This is implemented in the function getSelMatrix(). So far this is the same as the original stability selection procedure. Now we take into account the clusters. The function getClusterSelMatrix() takes in the formatted clusters as well as feat_sel_mat and generates the binary matrix clus_sel_mat, which contains selection indicators for each cluster. clus_sel_mat has the same number of rows as feat_sel_mat and one column for each cluster rather than one for each feature. This is used to calculate the cluster selection proportions. The function css() is specified below. (There are some extra details that I omitted in the above description for brevity; you can read the full details below.) #' Cluster Stability Selection #' #' Executes cluster stability selection algorithm. Takes subsamples of data, #' executes feature selection algorithm on each subsample, and returns matrices #' of feature selection indicators as well as cluster selection indicators. #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; can be anything that takes the form of an #' n-dimensional vector, with the ith entry corresponding to the ith row of X. #' Typically (and for default `fitfun = cssLasso`), `y` should be an n-dimensional #' numeric vector. Note that for the default `fitfun = cssLasso`, `y` must not be #' too discrete: every random subsample of `y` (of size `floor(n/2)`) must contain #' more than one unique value, or css aborts. Because the subsamples are random, #' such an abort is seed-dependent and becomes more likely as `B` grows; if it #' occurs, supply a less discrete (more continuous) response or a custom `fitfun` #' that tolerates a constant-`y` subsample. <<param-lambda>> <<param-clusters>> <<param-fitfun>> <<param-sampling_type>> <<param-B>> #' @param prop_feats_remove Numeric; if `prop_feats_remove` is greater than 0, #' then on each subsample, each feature is randomly dropped from the design #' matrix that is provided to `fitfun` with probability `prop_feats_remove` #' (independently across features). That is, in a typical subsample, #' `prop_feats_remove*p` features will be dropped (though this number will vary). #' This is similar in spirit (but distinct from) extended stability selection #' (Beinrucker et. al. 2016); see their paper for some of the benefits of #' dropping features (besides increasing computational speed and decreasing #' memory requirements). For `sampling_type="SS"`, the features dropped in #' each complementary pair of subsamples are identical in order to ensure that #' the theoretical guarantees of Faletto and Bien (2022) are retained within #' each individual pair of subsamples. (Note that this feature is not #' investigated either theoretically or in simulations by Faletto and Bien #' 2022). Must be between 0 and 1. Default is 0. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in `X` and `y` to set aside for model training by the #' function `getCssPreds()` after feature selection. (This will only work if `y` is #' real-valued, because `getCssPreds()` using ordinary least squares regression to #' generate predictions.) If `train_inds` is not provided, all of the observations #' in the provided data set will be used for feature selection. #' @param num_cores Optional; an integer. The number of cores to use for #' parallel processing (supplied internally as the `mc.cores` argument of #' `parallel::mclapply()`). The per-subsample feature-selection loop is the #' dominant cost and is embarrassingly parallel, so on a multi-core Unix or #' macOS machine setting `num_cores > 1` gives a substantial speedup; the result #' is identical regardless of `num_cores` (per-subsample seeds are fixed). #' On Windows, forking is unavailable, so `num_cores > 1` is not supported; #' `css()` warns and runs serially (`num_cores = 1`) there. Default is #' 1 (serial). #' @return A list containing the following items: #' \\item{`feat_sel_mat`}{A `B` (or `2*B` for `sampling_type="SS"`) x `p` numeric (binary) matrix. `feat_sel_mat[i, j] = 1` if feature `j` was selected by the base feature selection method on subsample `i`, and 0 otherwise.} #' \\item{`clus_sel_mat`}{A `B` (or `2*B` for SS sampling) x `length(clusters)` numeric (binary) matrix. `clus_sel_mat[i, j] = 1` if at least one feature from cluster j was selected by the base feature selection method on subsample `i`, and 0 otherwise.} #' \\item{`X`}{The `X` matrix provided to `css()`, coerced from a data.frame to a #' matrix if needed.} #' \\item{`y`}{The `y` vector provided to `css()`.} #' \\item{`clusters`}{A named list of integer vectors containing all of the clusters provided to `css()`, as well as size 1 clusters of any features not listed in any #' of the clusters provided to `css()`. All clusters will have names; any #' clusters not provided with a name in the input to `css()` will be given names #' automatically by `css()` (of the form c1, etc.).} #' \\item{`train_inds`}{Identical to the `train_inds` provided to `css()`.} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' <<shah2013>> #' #' Meinshausen, N., & Bühlmann, P. (2010). Stability Selection. \\emph{Journal of the Royal #' Statistical Society. Series B: Statistical Methodology}, 72(4), 417–473. #' \\url{https://doi.org/10.1111/j.1467-9868.2010.00740.x}. #' #' Beinrucker, A., Dogan, Ü., & #' Blanchard, G. (2016). Extensions of stability selection using subsamples of #' observations and covariates. \\emph{Statistics and Computing}, 26(5), 1059- #' 1077. \\url{https://doi.org/10.1007/s11222-015-9589-y}. #' #' Jerome Friedman, Trevor Hastie, Robert Tibshirani (2010). Regularization Paths for Generalized #' Linear Models via Coordinate Descent. \\emph{Journal of Statistical Software}, #' 33(1), 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' print(res) #' # On a multi-core Unix/macOS machine, set num_cores for a substantial #' # speedup (identical results; num_cores > 1 falls back to serial on Windows): #' \\donttest{ #' res_par <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10, num_cores = min(2L, parallel::detectCores())) #' } #' @export css <- function(X, y, lambda, clusters = list(), fitfun = cssLasso, sampling_type = "SS", B = 50L, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L ){ # Check inputs check_list <- checkCssInputs(X, y, lambda, clusters, fitfun, sampling_type, B, prop_feats_remove, train_inds, num_cores) feat_names <- check_list$feat_names X <- check_list$X clusters <- check_list$clusters rm(check_list) # num_cores > 1 needs forking (parallel::mclapply), which is unavailable on # Windows -- there mclapply hard-errors for mc.cores > 1 rather than running # serially. Downgrade to serial with a warning so css() still runs (#155d). if(num_cores > 1L && runningOnWindows()){ warning("num_cores > 1 is not supported on Windows (parallel::mclapply requires forking); running serially with num_cores = 1.") num_cores <- 1L } n <- nrow(X) p <- ncol(X) train_inds <- as.integer(train_inds) ### Create subsamples sel_inds <- setdiff(1:n, train_inds) n_sel <- length(sel_inds) if(n_sel < 4){ if(length(train_inds) == 0){ stop(paste0("Sample size n = ", n, " is too small; css needs at least 4 observations for feature selection.")) } else { stop("Too many training indices provided (must be at least 4 observations left for feature selection, and ideally many more)") } } subsamps_object <- createSubsamples(n_sel, p, B, sampling_type, prop_feats_remove) ### Get matrix of selected feature sets from subsamples stopifnot(!is.matrix(y)) # When train_inds is empty (the default), sel_inds is 1:n, so X[sel_inds, ] # / y[sel_inds] would just materialize a full-size copy of X / y for nothing # (getSelMatrix re-indexes rows per subsample anyway). Pass X / y directly in # that case; the result is byte-identical, since X[1:n, ] equals X (same # values and dimnames) and y[1:n] equals y. (#129) sel_X <- if(length(train_inds) == 0) X else X[sel_inds, ] sel_y <- if(length(train_inds) == 0) y else y[sel_inds] # Up-front diagnostic (#131): for the default cssLasso a highly discrete y can # leave some random size-floor(n/2) subsample with only one unique value, which # aborts the run non-deterministically (checkCssLassoInputs). Warn when that # estimated probability is non-negligible. Gated to the default cssLasso (custom # fitfuns may tolerate a constant-y subsample) and to finite numeric/integer y: # a non-numeric or non-finite y fails cssLasso for a different, more basic # reason (checkCssLassoInputs), and a non-finite value (Inf/NA) would otherwise # be miscounted by table() as a dominating value, so a discreteness warning # there would be misleading. Consumes no RNG (table/lchoose only), so the # selection below is byte-identical. if(identical(fitfun, cssLasso) && (is.numeric(sel_y) || is.integer(sel_y)) && all(is.finite(sel_y))){ abort_prob <- discreteYAbortProb(sel_y, B, sampling_type) # Warn only above a 5% estimated abort probability: high enough to stay # silent on common discrete data (balanced/moderate y compute to ~0) while # still catching genuinely majority-dominated y. Tunable constant. (#131) if(abort_prob > 0.05){ warning(paste0("The response y appears highly discrete: there is an ", "estimated ", round(100 * abort_prob), "% chance that at least one ", "random subsample of y (of size floor(n/2)) will contain only one ", "unique value, which aborts the default cssLasso (see its error). ", "Consider a less discrete (more continuous) response, a smaller B, ", "or a custom fitfun that tolerates a constant-y subsample.")) } } feat_sel_mat <- getSelMatrix(sel_X, sel_y, lambda, B, sampling_type, subsamps_object, num_cores, fitfun) if(any(!is.na(feat_names))){ colnames(feat_sel_mat) <- feat_names colnames(X) <- feat_names } ### Get selection proportions for clusters corresponding to each feature clus_sel_mat <- getClusterSelMatrix(clusters, feat_sel_mat) # Check outputs stopifnot(!is.null(colnames(clus_sel_mat))) stopifnot(all(colnames(clus_sel_mat) == names(clusters))) ret <- list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat, X = X, y = y, clusters = clusters, train_inds = train_inds ) class(ret) <- "cssr" return(ret) } Tests for css() and the other functions in this section are collected in the Tests chapters at the end of this document (the Tests part). Next, we’ll build the individual functions one at a time. (The one function above that I didn’t mention at all is checkCssInputs(), which confirms that the inputs to css() are as expected and does some basic formatting on the inputs. To streamline presentation, this and other helper functions are specified later.) 3.1 Main components of css 3.1.1 Generating subsamples The function createSubsamples() is responsible for generating the subsamples \\(A_b\\), where \\(b\\) ranges from 1 to \\(B\\) or 1 to \\(2B\\) depending on the type of subsampling: #' Creates lists of subsamples for stability selection. #' #' @param n Integer or numeric; sample size of the data set. #' @param p Integer or numeric; number of features. <<param-B>> <<param-sampling_type>> #' @param prop_feats_remove Numeric; the proportion of features (between 0 and 1) #' that are dropped (and not provided to the feature selection method) on each #' subsample. Default is 0. #' @return A list of length `B` (or `2*B` for `sampling_type = "SS"`). If #' `prop_feats_remove = 0`, each list element is an integer vector of length #' `floor(n/2)` containing the indices of a subsample of `1:n`. (For #' `sampling_type=="SS"`, the last `B` subsamples will be complementary pairs of #' the first `B` subsamples; see Faletto and Bien 2022 or Shah and Samworth 2013 #' for details.) If `prop_feats_remove > 0`, each element is a named list with #' members "subsample" (same as above) and "feats_to_keep", a logical vector #' of length `p`; `feats_to_keep[j] = TRUE` if feature `j` is chosen for this #' subsample, and false otherwise. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' <<shah2013>> #' @keywords internal #' @noRd createSubsamples <- function(n, p, B, sampling_type, prop_feats_remove=0){ # Check inputs stopifnot(length(n) == 1) stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n > 0) stopifnot(length(p) == 1) stopifnot(is.numeric(p) | is.integer(p)) stopifnot(p == round(p)) stopifnot(p > 0) checkSamplingType(sampling_type) checkPropFeatsRemove(prop_feats_remove, p) if(prop_feats_remove == 0){ subsamples <- getSubsamps(n, B, sampling_type) return(subsamples) } else{ # In this case, we generate subsamples as well as logical vectors # of features to keep # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). subsamps_and_feats <- vector("list", if(sampling_type == "SS") 2L*B else B) subsamples <- getSubsamps(n, B, sampling_type) for(i in 1:B){ # Logical p-vector, where each entry is TRUE with probability # 1 - prop_feats_remove feats_to_keep_i <- as.logical(stats::rbinom(n=p, size=1, prob=1 - prop_feats_remove)) # Make sure at least two entries are equal to TRUE (so that at # least two features are present for every subsample)--if not, # randomly choose features to add while(sum(feats_to_keep_i) < 2){ false_inds <- which(!feats_to_keep_i) sel_feat <- sample(false_inds, size=1) feats_to_keep_i[sel_feat] <- TRUE } subsamps_and_feats[[i]] <- list(subsample=subsamples[[i]], feats_to_keep=feats_to_keep_i) } # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). if(sampling_type=="SS"){ stopifnot(length(subsamples) == 2*B) for(i in 1:B){ # Keep the same features as in the other subsample (this # ensures that the theoretical guarantee of Shah and Samworth # 2013 remains valid on every individual pair of subsamples) subsamps_and_feats[[B + i]] <- list(subsample=subsamples[[B + i]], feats_to_keep=subsamps_and_feats[[i]]$feats_to_keep) } } # Check output: every element is a named list(subsample, feats_to_keep). # (The previous check ran on the unnamed OUTER list -> all(logical(0)) # -> vacuously TRUE; this validates the per-element invariant. #69) stopifnot(all(vapply(subsamps_and_feats, function(s) identical(names(s), c("subsample", "feats_to_keep")), logical(1)))) return(subsamps_and_feats) } # Shouldn't be possible to reach this part of function stop("createSubsamples failed to return anything") } Notice that createSubsamples() calls some helper functions to check the inputs (again, these are specified later in the helper functions section). createSubsamples() also calls the workhorse function getSubsamps() to generate a list of subsamples. #' Generate list of subsamples #' #` Generate list of `B` (or `2*B` for sampling_type="SS") subsamples of size #` `n/2` #' @param n Integer or numeric; sample size of the data set. <<param-B>> <<param-sampling_type>> #' @return A list of length `B` (or `2*B` for `sampling_type="SS"`), where each #' element is an integer vector of length `floor(n/2)` containing the indices #' of a subsample of `1:n`. For `sampling_type=="SS"`, the last `B` subsamples #' will be complementary pairs of the first `B` subsamples (see Faletto and #' Bien 2022 or Shah and Samworth 2013 for details). #' @author Gregory Faletto, Jacob Bien #' @references #' <<faletto2022>> #' <<shah2013>> #' @keywords internal #' @noRd getSubsamps <- function(n, B, sampling_type){ subsamples <- vector("list", B) for(i in 1:B){ subsamples[[i]] <- sort(sample.int(n=n, size=floor(n/2), replace=FALSE)) } stopifnot(length(subsamples) == B) # Only the "SS" branch is implemented; "MB" is withheld by checkSamplingType (see #138). if(sampling_type=="SS"){ for(i in 1:B){ # For the ith entry, take a subsample of size floor(n/2) from the # remaining n - floor(n/2) observations. (Only necessary to actually # take the subsample if n is odd; if not, the set we want is # setdiff(1:n, subsamples[[i]]), so skip the sample function.) if(n/2 == floor(n/2)){ subsamples[[B + i]] <- sort(setdiff(1:n, subsamples[[i]])) } else{ subsamples[[B + i]] <- sort(sample(x=setdiff(1:n, subsamples[[i]]), size=floor(n/2), replace=FALSE)) } # Check output stopifnot(is.integer(subsamples[[B + i]])) stopifnot(all(subsamples[[B + i]] == round(subsamples[[B + i]]))) stopifnot(floor(n/2) == length(subsamples[[B + i]])) stopifnot(length(subsamples[[B + i]]) == length(unique(subsamples[[B + i]]))) } stopifnot(length(subsamples) == 2*B) } return(subsamples) } 3.1.2 Forming selection matrices The next function called in the body of css() is getSelMatrix(), which records for each feature \\(j\\) and subsample \\(b\\) whether \\(j\\in \\hat S^\\lambda(A_b)\\): #' Generates matrix of selection indicators from stability selection. #' #' @param x an n x p numeric matrix or a data.frame containing the predictors. #' @param y A response vector; can be any response that takes the form of a #' length n vector and is used (or not used) by fitfun. Typically (and for #' default fitfun = cssLasso), y should be an n-dimensional numeric vector #' containing the response. <<param-lambda>> <<param-B>> <<param-sampling_type>> #' @param subsamps_object A list of length `B` (or `2*B` if `sampling_type="SS"`), #' where each element is one of the following: #' - `subsample`: An integer vector of size `n/2` containing the indices of the #' observations in the subsample. #' - `drop_var_input`: A named list containing two elements: one named #' "subsample", matching the previous description, and a logical vector named #' "feats_to_keep" containing the indices of the features to be automatically #' selected. #' #' (The first object is the output of the function `createSubsamples()` when the #' provided `prop_feats_remove` is 0, the default, and the second object is the #' output of `createSubsamples()` when `prop_feats_remove > 0`.) #' @param num_cores Optional; an integer. If using parallel processing, the #' number of cores to use for parallel processing (num_cores will be supplied #' internally as the mc.cores argument of parallel::mclapply). <<param-fitfun>> #' @return A binary integer matrix of dimension `B` x `p` (if sampling_type == #' "MB") or `2*B` x `p` (if sampling_type == "SS"). `res[i, j]` = 1 if feature j #' was selected on subsample i and equals 0 otherwise. (That is, each row is a #' selected set.) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelMatrix <- function(x, y, lambda, B, sampling_type, subsamps_object, num_cores, fitfun=cssLasso){ # Check inputs stopifnot(is.matrix(x)) stopifnot(all(!is.na(x))) n <- nrow(x) p <- ncol(x) stopifnot(length(y) == n) stopifnot(!is.matrix(y)) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. checkSamplingType(sampling_type) # Get list of selected feature sets from subsamples # Reproducible per-subsample seeding (issue #12): draw one seed per # subsample from the caller's RNG, then seed inside cssLoop right before # fitfun runs, so a stochastic fitfun is reproducible and identical across # serial/parallel/platform/num_cores given a seed set before css(). The # default cssLasso is deterministic and ignores the seed. Save and restore # .Random.seed so css() leaves the caller's RNG where the (pre-existing) # subsampling left it. if(exists(".Random.seed", envir=.GlobalEnv)){ old_seed <- get(".Random.seed", envir=.GlobalEnv) on.exit(assign(".Random.seed", old_seed, envir=.GlobalEnv), add=TRUE) } seeds <- sample.int(.Machine$integer.max, length(subsamps_object)) res_list <- parallel::mclapply(X=seq_along(subsamps_object), FUN=function(i){ warns <- list() value <- withCallingHandlers( tryCatch( cssLoop(subsamps_object[[i]], x=x, y=y, lambda=lambda, fitfun=fitfun, seed=seeds[i]), # (#155a) tag the TRUE subsample index at the point of failure # so prescheduling can't misattribute it in the assembly loop. error=function(e) structure(list(i=i, msg=conditionMessage(e)), class="cssr_loop_error") ), # (#155b) collect fitfun warning CONDITIONS from the (possibly # forked) worker; re-emitted in the parent below so they surface # the same regardless of num_cores. Collect the condition object # (not just conditionMessage) so a custom warning's subclass/call # survives (conditions serialize across the fork). warning=function(w){ warns[[length(warns) + 1L]] <<- w; invokeRestart("muffleWarning") } ) list(value=value, warnings=warns) }, mc.cores=num_cores) # mclapply returns NULL for any subsample whose worker was killed (e.g. the # OS out-of-memory killer). That NULL is distinct from a legitimate # integer(0) "selected nothing" result, so catch it here rather than letting # the assembly loop's length(res_list[[i]]) == 0 branch silently record it as # a zero row (which would bias the selection proportions). if(any(vapply(res_list, is.null, logical(1)))){ stop("A parallel worker failed (returned NULL) on at least one subsample; re-run with num_cores = 1 to see the underlying error.") } # (#155b) Re-emit fitfun warning conditions in subsample order, then unwrap # so the assembly loop below sees the plain results. for(i in seq_along(res_list)){ for(w in res_list[[i]]$warnings){ warning(w) } res_list[[i]] <- res_list[[i]]$value } # Store selected sets in B x p (or `2*B` x p for "SS") binary matrix if(sampling_type=="SS"){ res <- matrix(0L, 2*B, p) } else if(sampling_type=="MB"){ # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). res <- matrix(0L, B, p) } else{ stop("!(sampling_type %in% c(SS, MB)) (don't know how to set dimensions of res") } stopifnot(length(res_list) == nrow(res)) # Get selected sets into matrix res for(i in 1:nrow(res)){ if(length(res_list[[i]]) == 0){ # If no features are selected, don't fill in anything in this row next } if(!is.integer(res_list[[i]])){ stop(fitfunFailureMessage(res_list[[i]], i)) } stopifnot(length(res_list[[i]]) <= p & length(res_list[[i]]) > 0) stopifnot(all(!is.na(res_list[[i]]))) stopifnot(max(res_list[[i]]) <= p) stopifnot(min(res_list[[i]]) >= 1) stopifnot(length(res_list[[i]]) == length(unique(res_list[[i]]))) stopifnot(!("try-error" %in% class(res_list[[i]]) | "error" %in% class(res_list[[i]]) | "simpleError" %in% class(res_list[[i]]) | "condition" %in% class(res_list[[i]]))) # Store selected variables in the ith row of res res[i, res_list[[i]]] <- 1L } # Check output stopifnot(is.matrix(res)) if(sampling_type=="SS"){ stopifnot(nrow(res) == 2*B) } else{ stopifnot(nrow(res) == B) } stopifnot(ncol(res) == p) stopifnot(all(res %in% c(0, 1))) return(res) } Again, getSelMatrix() uses some helper functions to check the inputs for safety. getSelMatrix() leverages the function parallel::mclapply() package, in order to allow for parallel processing if the user has set this up. This requires a helper function cssLoop(), which is also specified in the later section for helper functions. We add the parallel package to the DESCRIPTION file: usethis::use_package("parallel") ## v Adding parallel to 'Imports' field in DESCRIPTION. ## [ ] Refer to functions with `parallel::fun()`. getSelMatrix() also uses a feature selection function fitfun as an input. fitfun can be provided by the user as an input to css(). We provide one default fitfun, cssLasso(), which works on a real-valued response y given a specified nonnegative penalty parameter lambda >= 0. Both for its own importance and to show an example of a valid fitfun, we show cssLasso() here. #' Provided fitfun implementing the lasso #' #' Function used to select features with the lasso on each subsample in cluster #' stability selection. Uses glmnet implementation of the lasso. #' @param X A design matrix containing the predictors. (In practice this will #' be a subsample of the full design matrix provided to `css()`.) #' @param y A numeric vector containing the response. #' @param lambda Either a single nonnegative number for the lasso penalty to #' use on each subsample (in which case a pure lasso fit, alpha = 1, is used), #' or a named length-2 numeric vector `c(lambda = <value>, alpha = <value>)` #' bundling the penalty together with the elastic net mixing parameter alpha #' (which must be in `(0, 1]`); in the latter case an elastic net fit with that #' alpha is used. (For now, only one lambda value can be provided to #' `cssLasso()`; in the future, we plan to allow for multiple lambda values to be #' provided to `cssLasso()`, as described in Faletto and Bien 2022.) #' @return An integer vector; the indices of the features selected by the lasso. #' @author Gregory Faletto, Jacob Bien #' @references #' <<faletto2022>> #' #' Jerome Friedman, Trevor Hastie, #' Robert Tibshirani (2010). Regularization Paths for Generalized Linear Models #' via Coordinate Descent. \\emph{Journal of Statistical Software}, 33(1), 1-22. #' URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' # cssLasso is the default base feature-selection method used by css(); #' # it returns the integer indices selected at the given lambda. #' selected <- cssLasso(X = data$X, y = data$y, lambda = 0.01) #' selected #' @export cssLasso <- function(X, y, lambda){ # Check inputs checkCssLassoInputs(X, y, lambda) n <- nrow(X) p <- ncol(X) # lambda may be either a single nonnegative number (pure lasso, as in the # original implementation) or a named length-2 numeric vector # c(lambda=<value>, alpha=<value>) bundling the elastic net mixing # parameter alpha alongside the penalty. Unpack alpha if it is provided. if(length(lambda) == 2){ alpha <- unname(lambda["alpha"]) lambda <- unname(lambda["lambda"]) } else{ alpha <- 1 } # Fit a lasso path (full path for speed, per glmnet documentation) lasso_model <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=alpha) stopifnot(all.equal(class(lasso_model), c("elnet", "glmnet"))) # Get coefficients at the desired lambda. predict.glmnet(exact=TRUE) used to # do this by refitting the whole path augmented with lambda -- including # every grid point BELOW lambda, which warm-started coordinate descent # solves after the target and which therefore cannot influence it. Instead # we fit that augmented grid ourselves, shortened by anchoredLambdaGrid() # and then predicted from with an ordinary exact=FALSE call. The shortened # grid keeps the augmented grid's own final element: predict.glmnet() # interpolates through glmnet:::lambda.interp(), which normalises by # lambda[1] - lambda[k], so the blend weight at lambda depends on the last # supplied grid point as well as the first, and dropping it changes the # answer in its last bits. anchoredLambdaGrid()'s n_interior argument is a # speed constant only; the coefficients here do not depend on it (#125). # The penalty finally predicted at is not lambda but snapLambdaToGrid()'s # reading of it off the fit; the comment at that call says why (#199). # # The short-circuit is a correctness requirement, not an optimisation. # Removing it changes the selected set on the on-grid route -- concentrated # at the top of the path, and by margins far larger than last-bit noise. # css() never reaches it (a subsample's target penalty is essentially never # one of that subsample's own fitted penalties); it is there to keep the # exported direct-call route byte-identical. The predicate is deliberately # the one predict.glmnet() itself applies, match(s, lambda, FALSE), so the # two agree about what "already on the grid" means. if(match(lambda, lasso_model$lambda, 0L) > 0){ fit_at_lambda <- lasso_model } else{ fit_at_lambda <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=alpha, lambda=anchoredLambdaGrid(lasso_model$lambda, lambda)) } # Predict at the penalty this fit actually holds, not at the one we asked # for. glmnet reports a supplied grid back through the response scale -- # divided by it and multiplied by it again -- so the entry that comes back # can sit an ULP away from what went in. predict.glmnet() with a numeric s # does not solve anything: it calls glmnet:::lambda.interp(), which locates # s between two grid columns and returns left, right and frac, and then # forms beta[, left]*frac + beta[, right]*(1 - frac). An ULP miss leaves # frac indistinguishable from 1 or from 0 -- WHICH ONE DEPENDS ON THE SIDE # THE MISS FALLS, measured at path positions 2-5: a miss upward, s above the # fitted entry, leaves frac indistinguishable from 0, and a miss downward # from 1. Do not write this as "a hair short of 1"; that is half the cases. # Either way the nearer entry is the column whose weight is indistinguishable # from 1 -- which follows from lambda.interp()'s construction rather than # only from the sweep -- so every coefficient the OTHER column carries and it # does not is scaled by the complement and SELECTED, because nonzeroCoef()'s # membership test is abs(x) > 0 with no tolerance. The leaked COEFFICIENTS # land around 1e-17; the complement itself is larger, so do not attach that # figure to it. Handing s the fit's own entry makes lambda.interp() report # left == right with frac == 1, so what comes back is the solved column with # its exact zeros (#199). # # Applied on BOTH routes rather than only on the refit route. On the # short-circuit route match(lambda, lasso_model$lambda, 0L) > 0 has already # established an exact hit, so the helper returns lambda unchanged there and # test_that("cssLasso short-circuits when lambda is already on the path # (#125)") stays green with its assertions untouched -- which is how that # claim is confirmed, by running it rather than by asserting it here. s <- snapLambdaToGrid(fit_at_lambda$lambda, lambda) pred <- glmnet::predict.glmnet(fit_at_lambda, type="nonzero", s=s) # predict.glmnet(type="nonzero") has never had a stable container. glmnet # 4.x returned a data.frame whenever apply() could simplify -- i.e. whenever # the per-s index counts were uniform -- and a list otherwise; glmnet >= 5.0 # always returns a list, one element per s value. For the scalar s used here # that rule makes 4.x yield a data.frame on a non-empty selection and a list # on an empty one, but the underlying rule is about simplification, not # emptiness. unlist() flattens every one of those shapes to the same integer # vector, so this is version-agnostic -- it is the idiom glmnet 5.0's own # NEWS prescribes for cross-version callers (#188). # # SAFE HERE ONLY BECAUSE s IS SCALAR, which two things together guarantee: # checkCssLassoInputs() rejects any lambda whose length is not 1 or 2, and # the unpacking above reduces the length-2 c(lambda=, alpha=) form to a # single penalty. (Both halves matter -- cssLasso() is exported, so it can # be called directly.) So pred has exactly one slot and unlist() cannot # union indices across s values. # # Do NOT copy this idiom to a call that leaves s unspecified: predict.glmnet # then returns one slot per penalty in the fitted path. clusterLassoCore() # does exactly that, and flattening its result would silently merge the # per-model-size sets that getClusterSelsFromGlmnet() consumes (#190). stopifnot(!("try-error" %in% class(pred) | "error" %in% class(pred) | "simpleError" %in% class(pred) | "condition" %in% class(pred))) selected_glmnet <- sort(unique(unlist(pred))) # No feature selected at this penalty: unlist() of the all-NULL result is # NULL, hence length 0. Replaces the previous is.null(pred[[1]]) test, which # inspected the container rather than the contents. if(length(selected_glmnet) == 0){ return(integer()) } stopifnot(length(selected_glmnet) <= ncol(X)) stopifnot(all(selected_glmnet == round(selected_glmnet))) # No duplicate check is needed: nonzeroCoef() builds each slot as which[x], # a logical subset of distinct column indices, so duplicates cannot arise # upstream. (Asserting it after unique() would be a guardrail blinded by its # own input rather than a real check.) selected <- as.integer(selected_glmnet) return(selected) } Notice that cssLasso() depends on the package glmnet, and calls the function checkCssLassoInputs(), which verifies that the inputs to cssLasso() are as needed. (In particular, the function css() imposes very few requirements on lambda and y to allow the end user flexibility for any specified fitfun. checkCssLassoInputs() ensures that y is a real-valued response, lambda is a nonnegative real number, etc.) cssLasso() also calls anchoredLambdaGrid(), which builds the short penalty grid the second lasso fit runs over–the grid is chosen so that the coefficients at the target penalty come out bit-identical to the full-path refit, at the price of one extra fit over a much shorter grid: it keeps the path down to the target penalty, a little geometric padding below it, and the path’s own final penalty, which the interpolation reads and which therefore cannot be dropped. Both checkCssLassoInputs() and anchoredLambdaGrid() are specified in the helper functions section later. We add glmnet to the DESCRIPTION file as well: usethis::use_package("glmnet") ## v Adding glmnet to 'Imports' field in DESCRIPTION. ## [ ] Refer to functions with `glmnet::fun()`. Finally, getClusterSelMatrix() is the last significant function called within css(). It takes the information from getSelMatrix(), i.e. whether feature \\(j\\in\\hat S^\\lambda(A_b)\\), and outputs for every cluster \\(C\\) whether \\(C\\cap S^\\lambda(A_b)\\neq\\emptyset\\). #' Get cluster selection matrix #' #' Given a matrix of feature selection indicator variables and a list of #' clusters of features, returns a matrix of cluster indicator variables. #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of formatClusters. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). #' @param res A binary integer matrix. `res[i, j]` = 1 if feature j was selected #' on subsample i and equals 0 otherwise, as in the output of `getSelMatrix()`. #' (That is, each row is a selected set.) #' @return A binary integer matrix with the same number of rows #' as res and length(clusters) columns. Entry i, j is 1 if at least #' one member of cluster j was selected on subsample i, and 0 otherwise. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getClusterSelMatrix <- function(clusters, res){ # Check input checkGetClusterSelMatrixInput(clusters, res) p <- ncol(res) n_clusters <- length(clusters) # Map each feature to its (unique) cluster, then aggregate selections per # cluster in one rowsum pass instead of apply()-ing over all rows once per # cluster (#57). Each feature is in exactly one cluster and every cluster is # non-empty (enforced by checkGetClusterSelMatrixInput -> checkClusters # above), so feat2clus is fully populated and rowsum's groups are exactly # 1:n_clusters. rowsum's reorder=TRUE returns groups in numeric order, so the # rows -- and thus columns after t() -- line up positionally with # names(clusters). feat2clus <- integer(p) for(j in 1:n_clusters){ feat2clus[clusters[[j]]] <- j } clust_counts <- rowsum(t(res), group = feat2clus) # n_clusters x nrow(res) res_n_clusters <- t(clust_counts > 0L) * 1L colnames(res_n_clusters) <- names(clusters) # Check output stopifnot(is.matrix(res_n_clusters)) stopifnot(identical(colnames(res_n_clusters), names(clusters))) stopifnot(all(res_n_clusters %in% c(0, 1))) stopifnot(ncol(res_n_clusters) == length(clusters)) return(res_n_clusters) } The helper function checkGetClusterSelMatrixInput() verifies the inputs to getClusterSelMatrix(). With the above and the helper functions below, the css() function is complete! 3.2 Helper functions Below, we specify some of the helper functions for css(), which are less important for understanding what css() does. The function checkCssInputs() is called at the beginning of the css() function. It confirms that the inputs to css() are as expected. Also, css() allows some flexibility in how the inputs are formatted, and checkCssInputs() converts the inputs into consistent formats for later use. The function checkCssClustersInput() is called within checkCssInputs(), and specifically checks the clusters input. formatClusters() modifies clusters, ensuring every feature appears in exactly one cluster (any unclustered features are put in a “cluster” by themselves). checkFormatClustersInput() verifies the input to formatClusters() for safety (this might seem a little redundant here, but formatClusters() is also called by different functions in this package). checkY() ensures (here and elsewhere) that the provided y is as expected. (In particular, in general the inputted y can be a vector of any type as long as the specified fitfun can handle y appropriately. For some function inputs, y must be a numeric vector. checkY() enforces this, among other things.) checkClusters() verifies that the output of formatClusters() is as expected. getPrototypes() identifies the prototypes of each cluster–the feature within each cluster that has the largest marginal sample correlation with y. identifyPrototype() is the workhorse of getPrototypes(), identifying the prototype given a single cluster. checkSamplingType() ensures that the input sampling_type is as expected. checkB() ensures that the input B is as expected. checkPropFeatsRemove() ensures that the input prop_feats_remove is as expected. The function cssLoop() is called within css(). In particular, it is a helper function needed in order to allow for parallel processing of the feature selection method on each of the subsamples. checkCssLoopOutput() verifies that the output of cssLoop() is as expected. This is particularly important because the user can specify their own feature selection method; checkCssLoopOutput() verifies that the output of the feature selection method is valid, and provides an informative error message if not. checkCssLassoInputs() checks that the inputs to the provided fitfun, cssLasso(), are as needed. anchoredLambdaGrid() builds the penalty grid that cssLasso() fits its second lasso path over, so that the solution at the target penalty is obtained without solving most of the path below it. Most, not all: the grid also retains a few padding penalties and the path’s final one, because the interpolation that reads the solution depends on both endpoints of the grid it is given. checkGetClusterSelMatrixInput() verifies that the input to getClusterSelMatrix() is as expected. Tests are written for all of these functions. To keep this chapter readable as continuous narrative, the tests are collected in the Tests chapters at the end of this document (the Tests part) rather than appearing inline after each function. Because every function is defined before that part, each test still runs only after all of its dependencies have been defined. Several of the entry points below accept either a numeric matrix or a data.frame for the design matrix and share the same coercion logic (convert the data.frame with model.matrix, drop the intercept column, and guard against a column-count change that would invalidate supplied cluster indices). We factor that logic into a single internal helper, coerceDataFrameToMatrix(), so the seven call sites stay in sync. #' Coerce a data.frame design matrix to a numeric matrix #' #' Shared helper for the several entry points that accept either a matrix or #' a data.frame `X`: if `X` is a data.frame, convert it with #' `stats::model.matrix(~ .)` and drop the intercept column. If the column #' count changed and clusters were supplied (which would invalidate the #' cluster indices), error. If `X` is already a numeric matrix it is returned #' unchanged; a non-numeric matrix (e.g. a character matrix) is rejected with #' an error. #' @param X A numeric matrix or a data.frame. #' @param clusters A list of integer vectors (the cluster assignments); the #' column-count guard only fires when `length(clusters) > 0`. #' @param arg_name Character; the name of the argument as it should appear in #' the error message's first sentence. Default "X". #' @param convert_phrase Character; the subject of the "Please convert ___" #' sentence. Defaults to `arg_name`; cssSelect passes "the data.frame X" to #' reproduce its existing message verbatim. #' @return The (possibly coerced) numeric matrix. #' @keywords internal #' @noRd coerceDataFrameToMatrix <- function(X, clusters, arg_name = "X", convert_phrase = arg_name){ if(is.data.frame(X)){ p <- ncol(X) X <- stats::model.matrix(~ ., X) # drop = FALSE: a single non-intercept column must stay a matrix. # Without it a 1-column data.frame collapses to a vector, ncol(X) is # NULL, and the guard below evaluates `... & logical(0)` -> the cryptic # "argument is of length zero" instead of letting the clean downstream # "p >= 2" check fire (#43). X <- X[, colnames(X) != "(Intercept)", drop = FALSE] if(length(clusters) > 0 & (p != ncol(X))){ stop(paste0("When stats::model.matrix converted the provided data.frame ", arg_name, " to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert ", convert_phrase, " to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.")) } } if(!is.numeric(X)){ stop(paste0("The provided ", arg_name, " must be a numeric matrix; storage mode \\"", storage.mode(X), "\\" was provided. If ", arg_name, " came from a data.frame, check for character or factor columns."), call. = FALSE) } X } checkNoNAs() guards a design matrix against missing and non-finite values, before any data.frame coercion: #' Error if a design matrix contains missing or non-finite values #' #' Shared guard for the X-accepting entry points. Checks the ORIGINAL input #' (matrix or data.frame) so a data.frame's NAs are caught before #' coerceDataFrameToMatrix()'s model.matrix() call silently drops NA rows #' (na.action = na.omit). Pairs with coerceDataFrameToMatrix(): call this #' first, then coerce. #' @param X A numeric matrix or a data.frame. #' @param arg_name Character; the argument name as it should appear in the #' error message. Default "X". #' @return Invisibly, `X` (unchanged) -- called for its side effect. #' @keywords internal #' @noRd checkNoNAs <- function(X, arg_name = "X"){ has_na <- any(is.na(X)) has_inf <- if(is.data.frame(X)){ any(vapply(X, function(col) is.numeric(col) && any(is.infinite(col)), logical(1))) } else if(is.numeric(X)){ any(is.infinite(X)) } else { FALSE } if(has_na || has_inf){ stop(paste0("The provided ", arg_name, " must not contain missing (NA) or non-finite (Inf) values; please ", "remove or impute them before calling this function."), call. = FALSE) } invisible(X) } checkFiniteY() guards a response vector against missing and non-finite values, before any lasso entry point fits on it: #' Error if a response vector contains missing or non-finite values #' #' Shared guard for the y-accepting lasso entry points. Requires a numeric #' (or integer) y and rejects any NA/NaN/Inf, so the lasso paths fail fast and #' deterministically (getLassoLambda fits cv.glmnet on a RANDOM subsample, so a #' non-finite y would otherwise error only when the bad value happened to be #' drawn). Mirrors checkNoNAs()'s message for consistency. #' @param y A numeric (real-valued) vector. #' @param arg_name Character; the argument name as it should appear in the #' error message. Default "y". #' @return Invisibly, `y` (unchanged) -- called for its side effect. #' @keywords internal #' @noRd checkFiniteY <- function(y, arg_name = "y"){ if(!(is.numeric(y) | is.integer(y))){ stop(paste0("The provided ", arg_name, " must be a numeric (real-valued) vector."), call. = FALSE) } if(any(!is.finite(y))){ stop(paste0("The provided ", arg_name, " must not contain missing (NA) or non-finite (Inf) values; please ", "remove or impute them before calling this function."), call. = FALSE) } invisible(y) } checkCssInputs(): #' Helper function to confirm that inputs to the function `css()` are as expected, #' and modify inputs if needed #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. #' @param y The response; can be anything that takes the form of an #' n-dimensional vector, with the ith entry corresponding to the ith row of X. #' Typically (and for default fitfun = cssLasso), y should be an n-dimensional #' numeric vector. <<param-lambda>> <<param-clusters>> #' @param fitfun A function; the feature selection function used on each #' subsample by cluster stability selection. This can be any feature selection #' method; the only requirement is that it accepts the arguments (and only the #' arguments) X, y, and lambda and returns an integer vector that is a subset of #' 1:p. For example, fitfun could be best subset selection or forward stepwise #' selection or LARS and lambda could be the desired model size; or fitfun could be the #' elastic net and lambda could be a length-two vector specifying lambda and #' alpha. Default is cssLasso, an implementation of lasso (relying on the R #' package glmnet), where lambda is a nonnegative numeric specifying the L1 #' penalty for the lasso, or a named length-2 vector c(lambda, alpha) for an #' elastic net fit. #' @param sampling_type A character vector; either "SS" or "MB". For "MB", #' all B subsamples are drawn randomly (as proposed by Meinshausen and Bühlmann #' 2010). For "SS", in addition to these B subsamples, the B complementary pair #' subsamples will be drawn as well (see Faletto and Bien 2022 or Shah and #' Samworth 2013 for details). Default is "SS", and "MB" is not supported yet. #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. #' @param prop_feats_remove Numeric; if prop_feats_remove is greater than 0, #' then on each subsample, each feature is randomly dropped from the design #' matrix that is provided to fitfun with probability prop_feats_remove #' (independently across features). That is, in a typical subsample, #' prop_feats_remove*p features will be dropped (though this number will vary). #' This is similar in spirit (but distinct from) extended stability selection #' (Beinrucker et. al. 2016); see their paper for some of the benefits of #' dropping features (besides increasing computational speed and decreasing #' memory requirements). For sampling_type="SS", the features dropped in #' each complementary pair of subsamples are identical in order to ensure that #' the theoretical guarantees of Faletto and Bien (2022) are retained within #' each individual pair of subsamples. (Note that this feature is not #' investigated either theoretically or in simulations by Faletto and Bien #' 2022). Must be between 0 and 1. Default is 0. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in X and y to set aside for model training by the #' function getCssPreds after feature selection. (This will only work if y is #' real-valued, because getCssPreds using ordinary least squares regression to #' generate predictions.) If train_inds is not provided, all of the observations #' in the provided data set will be used for feature selection. #' @param num_cores Optional; an integer. If using parallel processing, the #' number of cores to use for parallel processing (num_cores will be supplied #' internally as the mc.cores argument of parallel::mclapply). #' @return A named list with the following elements: \\item{feat_names}{A #' character vector containing the column names of X (if the provided X #' had column names). If the provided X did not have column names, feat_names #' will be NA.} \\item{X}{The provided X, converted to a matrix if it was #' originally provided as a data.frame, and with feature names removed if they #' had been provided.}\\item{clusters}{A list of integer vectors; each vector #' will contain the indices of a cluster of features. Any duplicated clusters #' provided in the input will be removed (when duplicated clusters carry #' different names, the first occurrence's name is kept).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssInputs <- function(X, y, lambda, clusters, fitfun, sampling_type, B, prop_feats_remove, train_inds, num_cores){ stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) feat_names <- as.character(NA) if(!is.null(colnames(X))){ feat_names <- colnames(X) } n <- nrow(X) p <- ncol(X) if(!is.null(colnames(X))){ feat_names <- colnames(X) } stopifnot(p >= 2) if(length(feat_names) > 1){ stopifnot(length(feat_names) == p) } else{ stopifnot(is.na(feat_names)) } colnames(X) <- character() stopifnot(length(y) == n) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. # Check clusters argument clusters <- checkCssClustersInput(clusters) # Derive cluster names AFTER checkCssClustersInput (which may drop duplicate # clusters), so the names line up with the deduplicated list passed to # formatClusters below (#156). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } ### Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clusters <- formatClusters(clusters, p=p, clust_names=clust_names)$clusters stopifnot(class(fitfun) == "function") stopifnot(length(fitfun) == 1) if(!setequal(names(formals(fitfun)), c("X", "y", "lambda"))){ err_mess <- paste("fitfun must accept exactly the arguments X, y, and lambda (in any order, with or without defaults). Detected arguments to fitfun:", paste(names(formals(fitfun)), collapse=", ")) stop(err_mess) } checkSamplingType(sampling_type) checkB(B) checkPropFeatsRemove(prop_feats_remove, p) stopifnot(is.numeric(train_inds) | is.integer(train_inds)) if(length(train_inds) > 0){ stopifnot(all(!is.na(train_inds))) stopifnot(all(round(train_inds) == train_inds)) stopifnot(length(train_inds) == length(unique(train_inds))) stopifnot(all(train_inds >= 1)) stopifnot(all(train_inds <= n)) stopifnot(length(train_inds) <= n - 2) stopifnot(length(train_inds) >= 1) } stopifnot(length(num_cores) == 1) stopifnot(is.integer(num_cores) | is.numeric(num_cores)) stopifnot(!is.na(num_cores)) stopifnot(num_cores == round(num_cores)) stopifnot(num_cores >= 1) n_cores_avail <- parallel::detectCores() # detectCores() returns NA when the count is indeterminable; only enforce the # upper bound when it is known, so an NA does not brick every css() call (#155c). if(!is.na(n_cores_avail)){ stopifnot(num_cores <= n_cores_avail) } return(list(feat_names=feat_names, X=X, clusters=clusters)) } checkCssClustersInput: #' Helper function to confirm that clusters input to css is as expected #' <<param-clusters>> #' @return Same as the input, but all of the clusters will be coerced to #' integers. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssClustersInput <- function(clusters){ stopifnot(!is.na(clusters)) if(is.list(clusters)){ stopifnot(all(!is.na(clusters))) if(length(clusters) > 0){ for(i in 1:length(clusters)){ stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(is.integer(clusters[[i]]) | is.numeric(clusters[[i]])) stopifnot(all(clusters[[i]] == round(clusters[[i]]))) stopifnot(all(clusters[[i]] >= 1)) clusters[[i]] <- as.integer(clusters[[i]]) } # Remove exact-duplicate clusters (documented behavior; keeps the first # occurrence, so its name wins). Distinct-but-overlapping clusters are # still rejected by the overlap check below (#156). clusters <- clusters[!duplicated(clusters)] if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ if(length(intersect(clusters[[i]], clusters[[j]])) != 0){ error_mes <- paste("Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: ", i, ", ", j, ".", sep="") stop(error_mes) } } } } } } else{ # If clusters is not a list, it should be a vector of indices of # features that are in the (one) cluster stopifnot(is.numeric(clusters) | is.integer(clusters)) stopifnot(length(clusters) == length(unique(clusters))) stopifnot(all(!is.na(clusters))) stopifnot(is.integer(clusters) | is.numeric(clusters)) stopifnot(all(clusters == round(clusters))) stopifnot(all(clusters >= 1)) clusters <- as.integer(clusters) } return(clusters) } formatClusters(): #' Formats clusters in standardized way, optionally estimating cluster #' prototypes #' #' @param clusters Either an integer vector of a list of integer vectors; each #' vector should contain the indices of a cluster of features. (If there is only #' one cluster, clusters can either be a list of length 1 or simply an integer #' vector.) If clusters is specified then R is ignored. #' @param p integer or numeric; the numbe of features in x (should match #' ncol(x), if x is provided) #' @param clust_names A character vector of the names of the clusters in #' clusters. #' @param get_prototypes Logical: if TRUE, will identify prototype from each #' cluster (the feature from each cluster that is most correlated with the #' response) for the protolasso. In this case, x and y must be provided. #' @param x n x p numeric matrix; design matrix. Only needs to be provided if #' get_prototypes is TRUE. #' @param y Numeric response vector; only needs to be provided if get_prototypes #' is TRUE. Note: in general, the css function does not require y to be a #' numeric vector, because the provided fitfun could use a different form of y #' (for example, a categorical response variable). However, y must be numeric in #' order to provide prototypes because the prototypes are determined using the #' correlation between cluster members (columns of x) and y. #' @param R Numeric p x p matrix; not currently used. Entry ij contains the #' "substitutive value" of feature i for feature j (diagonal must consist of #' ones, all entries must be between 0 and 1, and matrix must be symmetric) #' @return A named list with the following elements: \\item{clusters}{A named #' list where each entry is an integer vector of indices of features that are in #' a common cluster. (The length of list clusters is equal to the number of #' clusters.) All identified clusters are non-overlapping. All features appear #' in exactly one cluster (any unclustered features will be put in their own #' "cluster" of size 1).} \\item{multiple}{Logical; TRUE if there is more than #' one cluster of size greater than 1, FALSE otherwise.} \\item{prototypes}{only #' returned if get_prototypes=TRUE. An integer vector whose length is equal to #' the number of clusters. Entry i is the index of the feature belonging to #' cluster i that is most highly correlated with y (that is, the prototype for #' the cluster, as in the protolasso; see Reid and Tibshirani 2016).} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd formatClusters <- function(clusters=NA, p=-1, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA){ # Check inputs clusters <- checkFormatClustersInput(clusters, p, clust_names, get_prototypes, x, y, R) n <- nrow(x) multiple <- FALSE if(any(lengths(clusters) > 1)){ # & length(clusters) > 1 # Only care about clusters with more than one element (only ones that # need to be treated differently) # keep track of whether there's more than one cluster or not multiple <- sum(lengths(clusters) > 1) > 1 } # For any features not already in a cluster, add a cluster containing only # that feature orig_length_clusters <- length(clusters) stopifnot(p >= 1) for(i in 1:p){ feat_i_found <- FALSE if(orig_length_clusters > 0){ for(j in 1:orig_length_clusters){ # If i is in cluster j, break out of this loop and consider the # next i if(i %in% clusters[[j]]){ feat_i_found <- TRUE break } } } # If feature i wasn't found in any cluster, add a cluster containing # just feature i if(!feat_i_found){ clusters[[length(clusters) + 1]] <- i } } n_clusters <- length(clusters) # Add names to clusters if(is.null(names(clusters))){ names(clusters) <- paste("c", 1:n_clusters, sep="") } else{ # What clusters need names? unnamed_clusts <- which(is.na(names(clusters)) | names(clusters) == "") if(length(unnamed_clusts) > 0){ proposed_clust_names <- paste("c", unnamed_clusts, sep="") # Replace any proposed cluster names that are already in use if(any(proposed_clust_names %in% names(clusters))){ proposed_clust_names[proposed_clust_names %in% names(clusters)] <- paste("c", unnamed_clusts[proposed_clust_names %in% names(clusters)] + p, sep="") } while_counter <- 0 while(any(proposed_clust_names %in% names(clusters))){ proposed_clust_names[proposed_clust_names %in% names(clusters)] <- paste(proposed_clust_names[proposed_clust_names %in% names(clusters)], "_1", sep="") while_counter <- while_counter + 1 if(while_counter >= 100){ stop("Function formatClusters stuck in an infinite while loop") } } stopifnot(length(unnamed_clusts) == length(proposed_clust_names)) names(clusters)[unnamed_clusts] <- proposed_clust_names } } # Check output checkClusters(clusters, p) stopifnot(is.logical(multiple)) stopifnot(length(multiple) == 1) stopifnot(!is.na(multiple)) if(get_prototypes){ prototypes <- getPrototypes(clusters, x, y) return(list(clusters=clusters, multiple=multiple, prototypes=prototypes)) } else{ return(list(clusters=clusters, multiple=multiple)) } } checkFormatClustersInput(): #' Helper function to ensure that the inputs to formatClusters are as expected #' #' @param clusters Either an integer vector of a list of integer vectors; each #' vector should contain the indices of a cluster of features. (If there is only #' one cluster, clusters can either be a list of length 1 or simply an integer #' vector.) If clusters is specified then R is ignored. #' @param p integer or numeric; the numbe of features in x (should match #' ncol(x), if x is provided) #' @param clust_names A character vector of the names of the clusters in clusters. #' @param get_prototypes Logical: if TRUE, will identify prototype from each #' cluster (the feature from each cluster that is most correlated with the #' response) for the protolasso. In this case, x and y must be provided. #' @param x n x p numeric matrix; design matrix. Only needs to be provided if #' get_prototypes is TRUE. #' @param y Numeric response vector; only needs to be provided if get_prototypes #' is TRUE. Note: in general, the css function does not require y to be a #' numeric vector, because the provided fitfun could use a different form of y #' (for example, a categorical response variable). However, y must be numeric in #' order to provide prototypes because the prototypes are determined using the #' correlation between cluster members (columns of x) and y. #' @param R Numeric p x p matrix; not currently used. Entry ij contains the #' "substitutive value" of feature i for feature j (diagonal must consist of #' ones, all entries must be between 0 and 1, and matrix must be symmetric) #' @return A list of integer vectors; each vector will contain the indices of a #' cluster of features. Any duplicated clusters provided in the input will be #' removed (when duplicated clusters carry different names, the first #' occurrence's name is kept). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkFormatClustersInput <- function(clusters, p, clust_names, get_prototypes, x, y, R){ if(any(is.na(clusters)) & any(is.na(R))){ stop("Must specify one of clusters or R (or does one of these provided inputs contain NA?)") } stopifnot(is.integer(p) | is.numeric(p)) stopifnot(length(p) == 1) stopifnot(p == round(p)) stopifnot(!is.na(p)) if(p > 0){ stopifnot(p >= 2) } use_R <- FALSE if(any(is.na(clusters)) | length(clusters) == 0){ if(all(!is.na(R))){ stopifnot(is.matrix(R)) stopifnot(all(dim(R) == p)) stopifnot(all(diag(R) == 1)) stopifnot(identical(R, t(R))) stopifnot(all(!is.na(R))) stopifnot(all(R %in% c(0, 1))) use_R <- TRUE } } else{ stopifnot(!is.list(clusters) | all(lengths(clusters) >= 1)) stopifnot(is.list(clusters) | length(clusters) >= 1) stopifnot(all(!is.na(clusters))) if(is.list(clusters) & length(clusters) > 0){ for(i in 1:length(clusters)){ stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(all(clusters[[i]] >= 1)) stopifnot(is.integer(clusters[[i]])) } if(any(!is.na(clust_names))){ stopifnot(length(clust_names) == length(clusters)) } clusters <- clusters[!duplicated(clusters)] if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ stopifnot(length(intersect(clusters[[i]], clusters[[j]])) == 0) } } } } else if(!is.list(clusters)){ clusters_temp <- clusters clusters <- list() clusters[[1]] <- clusters_temp rm(clusters_temp) } } stopifnot(length(get_prototypes) == 1) stopifnot(is.logical(get_prototypes)) if(any(!is.na(clust_names))){ stopifnot(is.character(clust_names)) } if(get_prototypes){ stopifnot(all(!is.na(x))) stopifnot(is.matrix(x)) n <- nrow(x) checkY(y, n) } if(use_R){ # Determine clusters from R clusters <- list() for(i in 1:nrow(R)){ clusters[[i]] <- as.integer(which(R[i, ] > 0)) stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(is.integer(clusters[[i]])) } clusters <- unique(clusters) stopifnot(is.list(clusters)) if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ if(length(intersect(clusters[[i]], clusters[[j]])) != 0){ stop("Invalid R matrix with overlapping clusters (clusters must not be overlapping)") } } } } } # Bounds-check cluster indices against p now that clusters has been # normalized to a list (covers list, bare-vector, and R-derived clusters). # Guarded by p > 0 because formatClusters defaults p = -1 (a sentinel that # disables the p-dependent checks); seq_along is empty for an empty clusters # and any NA-containing input has already errored at the top of this # function, so every element here is a non-empty integer vector. if(p > 0){ for(i in seq_along(clusters)){ if(any(clusters[[i]] > p)){ stop(paste0("Cluster index ", max(clusters[[i]]), " exceeds the number of features (p = ", p, ")."), call. = FALSE) } } } stopifnot(is.list(clusters)) return(clusters) } checkY(): #' Helper function to confirm that the argument y to several functions is #' as expected #' #' @param y Numeric response vector. #' @param n Number of observations of covariates; should match length of y. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkY <- function(y, n){ stopifnot(all(is.finite(y))) stopifnot(is.numeric(y) | is.integer(y)) stopifnot(length(unique(y)) > 1) stopifnot(length(n) == 1) stopifnot(!is.na(n)) stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n > 0) stopifnot(n == length(y)) } checkClusters(): #' Helper function to confirm that the argument clusters to several functions is #' as expected #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of css or #' formatClusters. (The length of list clusters is equal to the number of #' clusters.) All identified clusters must be non-overlapping, and all features #' must appear in exactly one cluster (any unclustered features should be in #' their own "cluster" of size 1). #' @param p The number of features; must be at least as large as the number of #' clusters. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkClusters <- function(clusters, p){ stopifnot(is.list(clusters)) stopifnot(all(lengths(clusters) >= 1)) stopifnot(all(!is.na(clusters))) n_clusters <- length(clusters) stopifnot(n_clusters == length(unique(clusters))) stopifnot(n_clusters <= p) stopifnot(!is.null(names(clusters))) stopifnot(is.character(names(clusters))) stopifnot(all(!is.na(names(clusters)) & names(clusters) != "")) stopifnot(length(unique(names(clusters))) == n_clusters) all_clustered_feats <- integer() for(i in 1:n_clusters){ stopifnot(is.integer(clusters[[i]])) all_clustered_feats <- c(all_clustered_feats, clusters[[i]]) } stopifnot(length(all_clustered_feats) == p) stopifnot(length(unique(all_clustered_feats)) == p) stopifnot(all(all_clustered_feats <= p)) stopifnot(all(all_clustered_feats >= 1)) } getPrototypes(): #' Estimate prototypes from a list of clusters #' #' Takes in list of clusters, x, and y and returns an integer vector (of length #' equal to the number of clusters) of the indices of the feature prototypes #' (the features from each cluster most correlated with the response). #' #' @param clusters A list where each entry is an integer vector of indices of #' features that are in a common cluster. (The length of list clusters must be #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. Must only include clusters of size 2 or larger. #' @param x n x p numeric matrix; design matrix. #' @param y Numeric response vector. Note: in general, the css function does not #' require y to be a numeric vector, because the provided fitfun could use a #' different form of y (for example, a categorical response variable). However, #' y must be numeric in order to provide prototypes because the prototypes are #' determined using the correlation between cluster members (columns of x) and #' y. #' @return An integer vector of the same length as clusters. Entry j is the #' index of the feature identified as the prototype for cluster j. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getPrototypes <- function(clusters, x, y){ # Check inputs stopifnot(!is.list(clusters) | all(lengths(clusters) >= 1)) stopifnot(is.list(clusters) | length(clusters) >= 1) stopifnot(all(!is.na(x))) stopifnot(is.matrix(x)) n <- nrow(x) p <- ncol(x) checkY(y, n) # Identify prototypes if(length(clusters) > 0){ if(is.list(clusters)){ prototypes <- rep(as.integer(NA), length(clusters)) for(i in 1:length(clusters)){ prototypes[i] <- identifyPrototype(clusters[[i]], x, y) } } else{ # If clusters is not a list, then there is only one cluster. prototypes <- identifyPrototype(clusters, x, y) } } else{ prototypes <- integer() } # Check output stopifnot(is.integer(prototypes)) if(length(clusters) > 0){ if(is.list(clusters)){ stopifnot(length(prototypes) == length(clusters)) } else { stopifnot(length(prototypes) == 1) } } else{ stopifnot(length(prototypes) == 0) } stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) return(prototypes) } identifyPrototype(): #' Estimate prototypes from a single cluster #' #' Takes in a single cluster, x, and y and returns an integer of the index of #' the feature prototype (the feature from the cluster most correlated with the #' response). #' #' @param cluster_members_i An integer vector of indices of features that are in #' a common cluster. Must have length at least 2. #' @param x n x p numeric matrix; design matrix. #' @param y Numeric response vector. Note: in general, the css function does not #' require y to be a numeric vector, because the provided fitfun could use a #' different form of y (for example, a categorical response variable). However, #' y must be numeric in order to provide prototypes because the prototypes are #' determined using the correlation between cluster members (columns of x) and #' y. #' @return integer; the index of the feature identified as the prototype for #' the cluster. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd identifyPrototype <- function(cluster_members_i, x, y){ # Check input stopifnot(is.integer(cluster_members_i)) # If cluster only has one member, that member is the prototype if(length(cluster_members_i) == 1){ return(cluster_members_i) } # Choose which cluster member to represent cluster for stability # metric purposes by choosing the one most highly correlated # with y # All cluster-member correlations in one cor() call. A constant column (or # constant y) has undefined correlation -> treat as 0. (A whole-matrix # cor() can differ from a per-column loop in the last ULP and so flip # which.max on a near-tie -> a different but equally-valid prototype.) if(length(unique(y)) == 1){ warning("identifyPrototype: the response y has only one unique value") } # suppressWarnings: base cor() emits "the standard deviation is zero" for a # constant column; we want a silent 0 there, so muffle ONLY the cor() call # (the explicit constant-y warning above is kept). cors_i <- suppressWarnings(abs(stats::cor(x[, cluster_members_i, drop = FALSE], y))) cors_i <- as.numeric(cors_i) cors_i[is.na(cors_i)] <- 0 max_index_i <- which.max(cors_i)[1] stopifnot(length(max_index_i) == 1) stopifnot(max_index_i %in% 1:length(cluster_members_i)) ret <- cluster_members_i[max_index_i] # Check output stopifnot(is.integer(ret)) stopifnot(length(ret) == 1) stopifnot(ret %in% cluster_members_i) # (#129) Dropped a tautological assert here: ret == cluster_members_i[ # max_index_i], so x[, cluster_members_i][, max_index_i] is by construction # x[, ret]. The check could never fire, but it materialized a fresh # n x |cluster| submatrix copy of x on every prototype identification. return(ret) } checkSamplingType(): #' Helper function to confirm that the argument sampling_type to several #' functions is as expected #' #' @param sampling_type A character vector; either "SS" or "MB". "MB" is not #' supported yet. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkSamplingType <- function(sampling_type){ stopifnot(is.character(sampling_type)) stopifnot(length(sampling_type) == 1) stopifnot(!is.na(sampling_type)) stopifnot(sampling_type %in% c("SS", "MB")) if(sampling_type == "MB"){ stop("sampling_type MB is not yet supported (and isn't recommended anyway)") } } checkB(): #' Helper function to confirm that the argument B to several functions is as #' expected #' #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkB <- function(B){ stopifnot(length(B) == 1) stopifnot(is.numeric(B) | is.integer(B)) stopifnot(!is.na(B)) stopifnot(B == round(B)) stopifnot(B > 0) if(B < 10){ warning("Small values of B may lead to poor results.") } else if (B > 2000){ warning("Large values of B may require long computation times.") } } checkAlpha(): #' Confirm that the elastic-net mixing parameter alpha is as expected #' #' Shared validator for the alpha argument of getLassoLambda, getModelSize, #' cssSelect, and cssPredict: a single number in (0, 1] (alpha = 1 is the #' lasso). Factored out of those four functions, which each held a verbatim #' copy, so they cannot drift (#72). #' @param alpha Numeric or integer; the elastic-net mixing parameter. Must be #' length 1, non-NA, and in (0, 1]. #' @return No return value; called for the side effect of erroring on bad #' input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkAlpha <- function(alpha){ stopifnot(is.numeric(alpha) | is.integer(alpha)) stopifnot(length(alpha) == 1) stopifnot(!is.na(alpha)) stopifnot(alpha > 0) stopifnot(alpha <= 1) } checkPropFeatsRemove(): #' Helper function to confirm that the argument prop_feats_remove to several #' functions is as expected #' #' @param prop_feats_remove Numeric; proportion of features that are dropped on #' each subsample. Must be between 0 and 1. #' @param p The number of features; must be greater than 2 if prop_feats_remove #' is greater than 0. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkPropFeatsRemove <- function(prop_feats_remove, p){ stopifnot(length(prop_feats_remove) == 1) stopifnot(is.numeric(prop_feats_remove) | is.integer(prop_feats_remove)) stopifnot(!is.na(prop_feats_remove)) stopifnot(prop_feats_remove >= 0 & prop_feats_remove < 1) if(prop_feats_remove > 0){ # Make sure p is at least 2 or else this doesn't make sense stopifnot(p >= 2) } } cssLoop(): #' Helper function run on each subsample #' #' Runs provided feature selection method `fitfun` on each subsample for cluster #' stability selection (this function is called within `mclapply`). #' @param input Could be one of two things: #' - `subsample`: An integer vector of size `n/2` containing the indices of the #' observations in the subsample. #' - `drop_var_input`: A named list containing two elements: one named #' "subsample" and the same as the previous description, and a logical vector #' named "feats_to_keep" containing the indices of the features to be #' automatically selected. #' #' (The first object is the output of the function `createSubsamples()` when the #' provided `prop_feats_remove` is 0, the default, and the second object is the #' output of `createSubsamples()` when `prop_feats_remove > 0`.) #' @param x an n x p numeric matrix containing the predictors. (This should be #' the full design matrix provided to css.) #' @param y A response; can be any response that takes the form of a length n #' vector and is used (or not used) by `fitfun`. Typically (and for default #' `fitfun = cssLasso`), `y` should be an n-dimensional numeric vector containing the #' response. This should be the full response provided to css. #' @param lambda A tuning parameter or set of tuning parameters that may be used #' by the feature selection method. For example, in the default case when #' `fitfun = cssLasso`, `lambda` is a numeric: the penalty to use for each lasso #' fit. #' @param fitfun A function that takes in arguments X, y, and lambda and returns #' a vector of indices of the columns of X (selected features). #' @param seed Optional integer. If non-NULL, the random number generator is #' seeded with `set.seed(seed)` immediately before `fitfun` is called, so that a #' stochastic `fitfun` is reproducible and identical across serial and parallel #' execution. Default NULL (no seeding). Supplied internally by `getSelMatrix` #' (one reproducible seed per subsample); direct callers can leave it NULL. #' @return An integer vector; the indices of the features selected by `fitfun`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd cssLoop <- function(input, x, y, lambda, fitfun, seed=NULL){ # Check inputs stopifnot(is.matrix(x)) # NOTE: x is intentionally NOT re-scanned for NAs here. cssLoop is @noRd and # called only by getSelMatrix (via mclapply), which already validates that # the full x is NA-free once before the 2*B-subsample loop. Re-scanning the # whole n x p matrix every subsample was ~5s of pure redundant work at # n=p=2000 (#60); the upstream check makes it unnecessary on every reachable # path. colnames(x) <- character() n <- nrow(x) p <- ncol(x) stopifnot(length(y) == n) stopifnot(!is.matrix(y)) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. if(!is.list(input)){ subsample <- input feats_to_keep <- rep(TRUE, p) } else{ stopifnot(all(names(input) == c("subsample", "feats_to_keep"))) subsample <- input$subsample feats_to_keep <- input$feats_to_keep } stopifnot(is.integer(subsample)) stopifnot(all(subsample == round(subsample))) stopifnot(floor(n/2) == length(subsample)) stopifnot(length(subsample) == length(unique(subsample))) stopifnot(is.logical(feats_to_keep)) stopifnot(length(feats_to_keep) == p) # Seed immediately before fitfun so a stochastic fitfun is reproducible # across serial/parallel execution (issue #12). seed is NULL for the # deterministic default cssLasso path and for direct callers. if(!is.null(seed)){ set.seed(seed) } selected <- do.call(fitfun, list(X=x[subsample, feats_to_keep], y=y[subsample], lambda=lambda)) # Validate the RAW fitfun return against its documented contract (an # integer vector that is a subset of seq_len(p_sub), where p_sub is the # number of columns handed to fitfun) BEFORE remapping to original # feature indices. Remapping first -- which(feats_to_keep)[selected] -- # would let R's index arithmetic silently turn contract violations # (negative, logical, fractional, or NULL returns) into # plausible-but-wrong selections (#151). p_sub <- sum(feats_to_keep) checkCssLoopOutput(selected, p_sub, seq_len(p_sub)) selected <- which(feats_to_keep)[as.integer(selected)] # Defensive post-remap check: once the raw return validates and the # remap is a plain index lookup, the remapped indices are guaranteed a # valid subset of the original features -- but keep the check as cheap # insurance at the user-code boundary. checkCssLoopOutput(selected, p, as.integer(which(feats_to_keep))) return(as.integer(selected)) } checkCssLoopOutput(): #' Helper function to confirm that the outputs of the provided feature selection #' method are as required. #' #' @param selected An integer vector; the indices of the features selected by #' the lasso. #' @param p The total number of observed features; all selected features must be #' in 1:p. #' @param feats_on_subsamp Integer; the indices of the features considered by #' the feature selection method. All selected features must be among these #' features. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssLoopOutput <- function(selected, p, feats_on_subsamp){ if(is.null(selected)){ stop("The provided feature selection method fitfun returned NULL on (at least) one subsample; to select no features, return integer(0).") } if(is.logical(selected)){ stop("The provided feature selection method fitfun returned a logical vector on (at least) one subsample; it must return integer indices of the selected features (e.g. which(coef != 0)).") } if(!is.integer(selected) & !is.numeric(selected)){ stop("The provided feature selection method fitfun failed to return an integer or numeric vector on (at least) one subsample") } if(any(is.na(selected))){ stop("The provided feature selection method fitfun returned a vector containing NA values on (at least) one subsample") } if(!all(selected == round(selected))){ stop("The provided feature selection method fitfun failed to return a vector of valid (integer) indices on (at least) one subsample") } if(length(selected) != length(unique(selected))){ stop("The provided feature selection method fitfun returned a vector of selected features containing repeated indices on (at least) one subsample") } if(length(selected) > p){ stop("The provided feature selection method fitfun returned a vector of selected features longer than p on (at least) one subsample") } if(length(selected) > 0){ if(max(selected) > p){ stop("The provided feature selection method fitfun returned a vector of selected features containing an index greater than ncol(X) on (at least) one subsample") } if(min(selected) <= 0){ stop("The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample") } } if("try-error" %in% class(selected) | "error" %in% class(selected) | "simpleError" %in% class(selected) | "condition" %in% class(selected)){ stop("The provided feature selection method fitfun returned an error on (at least) one subsample") } if(!all(selected %in% feats_on_subsamp)){ stop("The provided feature selection method somehow selected features that were not provided for it to consider.") } } fitfunFailureMessage() builds the informative error that getSelMatrix() raises when a subsample’s fitfun result is not a valid integer vector. getSelMatrix() wraps each subsample’s cssLoop() call in a tryCatch() that tags a failure with its true subsample index as a cssr_loop_error, so a fitfun error is reported the same way whether the run is serial or parallel (and prescheduling can no longer misattribute it to the wrong subsample); the try-error branch is a defensive fallback: #' Build an informative error for a subsample whose fitfun result is invalid #' #' Reached when cssLoop failed on a subsample. getSelMatrix wraps each #' subsample's cssLoop call in a tryCatch that tags the failure with its true #' subsample index as a cssr_loop_error (on both the serial and parallel paths), #' so the message names the correct subsample rather than a #' prescheduling-misattributed one. Surfaces the underlying cause in the error #' condition rather than printing it to stdout. #' @param result The offending element of getSelMatrix's res_list (normally a #' cssr_loop_error carrying the tagged subsample index and message; the #' try-error and class branches are defensive fallbacks). #' @param i Integer; the loop index of the subsample that failed (used only by #' the fallback branches -- a cssr_loop_error carries its own tagged index). #' @return A length-one character string suitable for stop(). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd fitfunFailureMessage <- function(result, i){ if(inherits(result, "cssr_loop_error")){ return(paste0("The feature selection method (fitfun) failed on subsample ", result$i, ": ", result$msg)) } if(inherits(result, "try-error")){ paste0("The feature selection method (fitfun) failed on subsample ", i, ": ", conditionMessage(attr(result, "condition"))) } else{ paste0("The feature selection method (fitfun) returned an object of ", "class ", paste(class(result), collapse = "/"), " on subsample ", i, "; it must return an integer vector of selected feature indices.") } } A small platform helper lets css() decide whether parallel forking is available. It is factored out (rather than inlined) so the Windows fallback can be exercised on non-Windows machines in the tests: #' Is the current session running on Windows? #' #' parallel::mclapply relies on forking, which is unavailable on Windows; css() #' uses this to downgrade num_cores > 1 to serial there rather than let mclapply #' hard-error (#155d). Factored into a helper so the Windows branch is #' unit-testable off-Windows via local_mocked_bindings. #' @return TRUE if running on Windows, FALSE otherwise. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd runningOnWindows <- function(){ identical(.Platform$OS.type, "windows") } checkCssLassoInputs(): #' Helper function to confirm that the inputs to `cssLasso()` are as expected. #' #' @param X A design matrix containing the predictors. (Note that we don't need #' to check X very much, because X will have already been checked by the #' function `checkCssInputs()` when it was provided to `css()`.) #' @param y A numeric vector containing the response. #' @param lambda Either a single nonnegative number for the lasso penalty to #' use on each subsample, or a named length-2 numeric vector #' `c(lambda = <value>, alpha = <value>)` bundling the penalty together with the #' elastic net mixing parameter alpha (which must be in `(0, 1]`). (For now, #' only one lambda value can be provided to `cssLasso()`; in the future, we plan #' to allow for multiple lambda values to be provided to `cssLasso()`, as #' described in Faletto and Bien 2022.) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssLassoInputs <- function(X, y, lambda){ n <- nrow(X) p <- ncol(X) if(!is.numeric(y) & !is.integer(y)){ stop("For method cssLasso, y must be a numeric or integer vector.") } if(any(!is.finite(y))){ stop("For method cssLasso, y must not contain missing (NA) or non-finite (Inf) values.") } if(is.matrix(y)){ stop("For method cssLasso, y must be a numeric vector (inputted y was a matrix).") } if(n != length(y)){ stop("For method cssLasso, y must be a vector of length equal to nrow(X).") } if(length(unique(y)) <= 1){ stop("Subsample with only one unique value of y detected: for the default cssLasso, every subsample of y (of size floor(n/2)) must have more than one unique value. css draws random subsamples, so this abort is seed-dependent and becomes more likely as B grows. It indicates that y is too discrete for the default cssLasso--supply a less discrete (more continuous) response, or pass a custom fitfun that tolerates a constant-y subsample.") } if(!is.numeric(lambda) & !is.integer(lambda)){ stop("For method cssLasso, lambda must be a numeric.") } if(any(is.na(lambda))){ stop("NA detected in provided lambda input to cssLasso") } # lambda may be either a single nonnegative number (pure lasso) or a named # length-2 numeric vector c(lambda=<value>, alpha=<value>) bundling the # elastic net mixing parameter alpha (in (0, 1]) alongside the penalty. if(length(lambda) == 1){ if(lambda < 0){ stop("For method cssLasso, lambda must be nonnegative.") } } else if(length(lambda) == 2){ if(!setequal(names(lambda), c("lambda", "alpha"))){ stop("For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).") } if(lambda["lambda"] < 0){ stop("For method cssLasso, the lambda component of lambda must be nonnegative.") } if(lambda["alpha"] <= 0 | lambda["alpha"] > 1){ stop("For method cssLasso, the alpha component of lambda must be in (0, 1].") } } else{ stop("For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).") } } anchoredLambdaGrid() builds the penalty grid that cssLasso()’s second glmnet fit runs over, replacing the full-path refit that predict.glmnet(exact = TRUE) used to perform internally (#125): #' Build an anchored, padded lambda grid for a second glmnet fit #' #' Returns a shortened version of the augmented penalty grid #' `unique(rev(sort(c(s, lambda_path))))` that `predict.glmnet(exact = TRUE)` #' refits over: that grid's prefix through one element past `s`, a few #' geometrically spaced interior points, and that grid's own final element #' re-appended. `cssLasso()` fits over this instead of over the whole augmented #' grid. The comments in the body say why the first and last elements are #' carried over unchanged, why each guard is there, and which test block #' enforces the construction. #' #' @param lambda_path A numeric vector of penalties (in practice the `$lambda` #' component of a fitted `glmnet` object). This is a requirement on the caller #' rather than a claim about what `glmnet()` returns: because the interior #' points are spaced in log space, `lambda_path` must not contain a zero unless #' `s` is at or below its smallest positive entry. Any other path containing a #' zero takes `log(0)` and errors in `seq()`; nothing checks it at runtime. #' @param s The target penalty; a single nonnegative number. #' @param n_interior The number of geometrically spaced interior points padding #' the gap below `s`. This is a speed constant and not a correctness one: the #' coefficients the returned grid yields at `s` do not depend on it, and 5 was #' chosen by end-to-end timing of `css()`, in particular for the n < p corner #' where 0 interior points is a net loss. Changing it changes speed only. #' @return A strictly decreasing numeric vector with no duplicated entries, #' whose first and last elements are `identical()` to those of #' `unique(rev(sort(c(s, lambda_path))))`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd anchoredLambdaGrid <- function(lambda_path, s, n_interior=5L){ # g_full is the grid predict.glmnet(exact=TRUE) refits over -- the fitted # path augmented with s, de-duplicated and ordered decreasing. The # expression is glmnet's own operator for operator, so both sides drop NA and # NaN (sort() keeps +-Inf) and collapse repeats identically. g_full <- unique(rev(sort(c(s, lambda_path)))) k_full <- length(g_full) # glmnet walks a grid in decreasing order with each solution warm-starting # the next, so the solution at s depends only on penalties at or above s; # kt counts those. The prefix is kept through one element PAST s because # predict.glmnet interpolates between s's two neighbours in the grid, and # that extra element is the one lambda.interp() calls `right` -- the next # penalty DOWN, since the grid is ordered decreasing. The min() caps the index # for the case where kt already reaches the end of g_full and there is no # further element to keep -- s = 0, and any s at or below min(lambda_path). kt <- sum(g_full >= s) keep <- g_full[1:min(k_full, kt + 1L)] lo <- g_full[k_full] hi <- keep[length(keep)] # Two cases have no gap to pad: n_interior <= 0, the caller asking for no # padding, and hi <= lo, keep already reaching the end of g_full. That is a # wider set than the min() cap above: it holds whenever s is the smallest or # the SECOND smallest element of g_full, so a user penalty falling between # the two smallest fitted ones also lands here and gets the augmented grid # unshortened, which is correct and saves nothing. This guard is also what # keeps log(0) out of the seq() below on a degenerate glmnet path, which is # a case that genuinely occurs rather than a hypothetical one. The condition # is max(abs(crossprod(X, y))) == 0 EXACTLY -- not merely an orthogonal # design, and not a numerically small value: measured, an orthonormal X with # a generic y gives an ordinary path, and so does one with max|X'y| at 1e-16. # At exact zero glmnet returns NaN followed by zeros for $lambda; sort() then # drops the NaN and unique() collapses the zeros, leaving a g_full of two # elements that lands here. Pinned end to end by # test_that("cssLasso survives a degenerate lasso path (#125)"), which drives # such a design through cssLasso() and asserts an empty selection rather than # an error. Note that the repo's older #157 fixture does NOT reach this # function: it goes through clusterLassoCore(), which never calls cssLasso(). if(n_interior <= 0 | hi <= lo){ return(unique(c(keep, lo))) } # Geometrically spaced filler between the two anchors, with the anchors # themselves dropped back off... mid <- exp(seq(log(hi), log(lo), length.out=n_interior + 2L)) mid <- mid[-c(1L, length(mid))] # ...and then any filler point that floating-point rounding placed on top of # an anchor removed. This filter is load-bearing rather than belt-and- # braces: without it the returned grid can repeat an anchor, which is # visible only on a path whose entries are a few ULPs apart. mid <- mid[mid < hi & mid > lo] # lo is re-appended rather than simply left at the end of a longer prefix, # and this is the load-bearing line. glmnet:::lambda.interp(), which # predict.glmnet() always calls, normalises by lambda[1] - lambda[k]. # # READ THIS BEFORE DELETING THE ANCHOR ON ALGEBRAIC GROUNDS. That normaliser # CANCELS in exact arithmetic: work the two ratios through and the weight is # just (lambda_right - s)/(lambda_right - lambda_left), with no dependence on # the grid's last element at all. So a maintainer who reasons this through # symbolically will correctly conclude the anchor is unnecessary -- and be # wrong, because in floating point the cancellation is inexact. Measured over # 1000 s values on two grids sharing every element but the last: the weight # differed in 74% of them, by up to 6 ULP, with left and right identical. # The anchor exists to reproduce the ROUNDING, not the algebra. Handing over # the same first and last elements the exact refit would have handed over is # what makes the interpolated coefficients agree bit for bit. # # This construction was validated over a six-figure sweep of designs, alphas # and s placements; the evidence is in PR #200, which is where to look # rather than at any local planning directory. Do not "simplify" it without # re-running that evidence. # The block that enforces it is test_that("anchoredLambdaGrid holds its # invariants (#125)"), NOT test_that("cssLasso is byte-identical to the # exact refit (#125)"): every natural simplification of this construction -- # dropping this re-appended anchor, keeping the prefix through kt rather than # kt + 1, and dropping the filter above -- leaves that identity pin entirely # green. return(c(keep, sort(unique(mid), decreasing=TRUE), lo)) } snapLambdaToGrid() recovers the penalty glmnet() actually fitted from the penalty cssLasso() asked for, so that predict.glmnet() reads a solved lasso path column instead of blending two adjacent ones (#199): #' Recover the fitted penalty a requested one round-tripped into #' #' Returns the element of `lambda_fitted` within `n_ulp` units in the last place #' of `s` when there is one, and `s` itself otherwise. `cssLasso()` predicts at #' the returned value rather than at `s`, which is what makes #' `predict.glmnet()` hand back a solved lasso path column, exact zeros #' included, instead of a blend of two adjacent columns. The comments in the #' body say why a tolerance this small is enough, why its two ends are bounded #' by different mechanisms, and what the function deliberately does not check. #' #' @param lambda_fitted A numeric vector of penalties (in practice the #' `$lambda` component of a fitted `glmnet` object). It may contain `NaN`, and #' it may be empty or entirely `NaN`; the last two return `s` unchanged. #' @param s The target penalty; a single nonnegative number. #' @param n_ulp The tolerance, in units in the last place of `s`: an entry of #' `lambda_fitted` matches `s` when it is within #' `n_ulp * .Machine$double.eps * s` of it. The scaling by `s` is part of the #' contract rather than an implementation detail, because the error being #' tolerated is relative. #' @return A single number: the matching element of `lambda_fitted` if there is #' one, and otherwise `s`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd snapLambdaToGrid <- function(lambda_fitted, s, n_ulp=4L){ # The one thing this function does check, and it is about s rather than # lambda_fitted, so it does not touch the no-validation decision recorded # below. WHAT IT ACTUALLY BUYS, measured rather than reasoned, because an # earlier revision of this comment claimed the wrong crossing: the sibling # anchoredLambdaGrid(lambda_path, s, n_interior) has the same arity and the # same second formal and sits in the chunk above, so a crossed call is easy # to write. Handing THIS function the anchored site's arguments passes a # scalar s, so this line never fires on that crossing, which is caught by the # two #199 red-green assertions rather than by this. (Do not restate that as # "the suite output is byte-identical with and without this line": since the # invariants block gained an expect_error() for this guard, deleting the # guard moves the suite whatever else is wrong.) What this line converts is # the TRANSPOSED call, where s is the fitted path. Without it the error comes # from the && in the tolerance test below -- which.min() itself is untroubled # and returns an index -- and reads as a coercion complaint about a length # nothing in this file explains. With it the failure names the precondition # and the line that holds it. No # legitimate caller can reach it -- checkCssLassoInputs() rejects any lambda # whose length is not 1 or 2, and the length-2 form is unpacked before the # call site -- so it is a tripwire, not a runtime check. stopifnot(length(s) == 1L) # WHY A TOLERANCE OF A FEW ULP IS THE RIGHT SIZE, and why that is a claim # about IEEE-754 rather than about this machine. glmnet() passes a supplied # penalty grid through as ulam = as.double(rev(sort(lambda))) and reports # $lambda back divided by the response scale and multiplied by it again. # That is two correctly-rounded scalar operations -- no matrix arithmetic, # so no BLAS -- and it is the whole reason a supplied penalty need not come # back verbatim. Predicting at the returned entry rather than at s is what # makes glmnet:::lambda.interp() report left == right with frac == 1, so # predict.glmnet() returns beta[, left] * 1 + beta[, right] * 0 -- the # solved column, exact zeros included -- instead of a blend that leaks the # neighbouring column's coefficients in at the scale of 1 - frac. Those # leaked coefficients are around 1e-17 and are SELECTED, because # glmnet:::nonzeroCoef()'s membership test is abs(x) > 0 with no tolerance # (#199). # # THE INSENSITIVITY OF n_ulp IS ONE-SIDED, and each end is bounded by a # different mechanism. Downwards it is not insensitive at all: measured, the # suite reddens at n_ulp = 2 and the invariants fixtures stop snapping at 1, # so the value is pinned from below and 4 carries a factor of two over the # nearest failing one. Upwards, on cssLasso()'s ordinary route, # anchoredLambdaGrid() has already placed s in the grid handed to glmnet(), # so which.min() below picks s's own echo and no n_ulp, however large, # reaches past it; only on a route where s is absent from the fitted path # does the spacing of that path become the operative bound -- and on # glmnet's default grids that spacing is of order 1e14 ulp, so it is not a # bound n_ulp can approach. # # NOTHING HERE VALIDATES lambda_fitted, and that is a decision rather than # an omission -- the same one anchoredLambdaGrid()'s roxygen states for its # own requirement on the caller. What is MEASURED, and nothing wider than # that, because two earlier revisions of this comment stated a rule and were # wrong both times: all(lambda_fitted > 0) reddens the suite, and # all(is.finite(lambda_fitted)) reddens it too, because the fixtures # deliberately drive a zero-bearing grid and a NaN-bearing one through this # function. A type check does NOT -- stopifnot(is.numeric(lambda_fitted)) # leaves the suite byte-identically green -- so this is not a rule about # validation in general and must not be written as one. The reason # it matters beyond bookkeeping is the degenerate lasso path: a validating # helper would turn that case from an empty selection into an error, on # exactly the shape issue #157 was filed to stop crashing, which is what # test_that("cssLasso survives a degenerate lasso path (#125)") exists to # hold. (Two earlier revisions of this comment enumerated which check # reddens which block and were wrong both times; the positive form above is # the correction.) # The length(j) == 1L clause below is control flow and not validation: an # all-NaN or empty lambda_fitted makes which.min() return integer(0), and # if(logical(0)) aborts, so the clause turns that case into "return s". # # THE INVARIANT cssLasso()'S NEW READ ASSUMES, named here rather than # asserted, for the reason just given. cssLasso() asserts the class of its # FIRST fit and nothing about its second, and until #199 the second fit's # $lambda was consumed only by predict.glmnet(), which owns its own # contract. What is now silently assumed of it is that it is a numeric # vector with at least one non-NaN entry, on the same scale as lambda. # # THE FIRST FORMAL IS lambda_fitted AND NOT lambda_path DELIBERATELY. The # sibling anchoredLambdaGrid(lambda_path, s, n_interior) has the same arity, # the same second formal and the chunk immediately above, so a CROSSED call # -- this function given the anchored site's arguments, both in their usual # order -- type-checks and runs, and would predict at a penalty chosen from # the wrong fit's path. (The TRANSPOSED call, arguments swapped, errors on # the scalar guard above; and neither is the route to #190's per-s-slot # union, which comes from calling predict.glmnet() with no s at all.) The # differing name is the one # signal at a call site that these take different things: the FIRST fit's # path going in, the SECOND fit's returned penalties coming back. # # The block that enforces this arithmetic is # test_that("snapLambdaToGrid holds its invariants (#199)"); the block that # enforces the call site in cssLasso() is # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). j <- which.min(abs(lambda_fitted - s)) if(length(j) == 1L && abs(lambda_fitted[j] - s) <= n_ulp*.Machine$double.eps*s){ return(lambda_fitted[j]) } return(s) } discreteYAbortProb() powers the up-front css() diagnostic for a highly discrete response (issue #131). For the default cssLasso, it estimates the probability that at least one random size-floor(n/2) subsample of y contains only a single unique value (which aborts the run in checkCssLassoInputs()). Per subsample this probability is hypergeometric; the crucial property is that it is nonzero only when some value’s count is at least floor(n/2) (a near-majority), so a balanced binary y does not trip it while a strongly majority-dominated y does: #' Estimated probability the default cssLasso aborts on a constant-y subsample #' #' For the default `cssLasso`, `css()` draws `n_sub` random subsamples of the #' selection set, each a size-`floor(n/2)` draw without replacement from the #' `n = length(y)` responses; `cssLasso` aborts on any subsample whose `y` has a #' single unique value (see `checkCssLassoInputs()`). This returns the estimated #' probability that at least one of those subsamples is all-constant. Per #' subsample, P(all one value) is hypergeometric, `sum_v C(count_v, m) / C(n, m)` #' with `m = floor(n/2)` (a term is 0 unless some value's count is at least `m`, #' i.e. that value is a near-majority), computed in log space (`lchoose`) to #' avoid overflow for large `n`. That per-subsample probability is aggregated #' over the `n_sub` subsamples treating them as independent (a close #' approximation; the small SS within-pair dependence is negligible near the #' threshold). #' #' @param y A numeric or integer response vector (the selection-set response). #' @param B Integer; the number of subsamples (`2*B` are drawn when #' `sampling_type = "SS"`). #' @param sampling_type A character string; "SS" (the reachable default) draws #' `2*B` subsamples, anything else draws `B`. #' @return A single number in `[0, 1]`: the estimated probability that at least #' one size-`floor(n/2)` subsample of `y` is all-constant (and so aborts the #' default `cssLasso`). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd discreteYAbortProb <- function(y, B, sampling_type){ n <- length(y) m <- floor(n / 2) n_sub <- if(sampling_type == "SS") 2L * B else as.integer(B) counts <- as.integer(table(y)) p_const <- sum(exp(lchoose(counts, m) - lchoose(n, m))) # sum_v C(count_v,m)/C(n,m) p_const <- min(max(p_const, 0), 1) # guard fp drift to [0,1] 1 - (1 - p_const)^n_sub } checkGetClusterSelMatrixInput(): #' Helper function to check inputs to getClusterSelMatrix function #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of formatClusters. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). #' @param res A binary integer matrix. `res[i, j]` = 1 if feature j was selected #' on subsample i and equals 0 otherwise, as in the output of getSelMatrix. #' (That is, each row is a selected set.) #' @return No return value; called for the side effect of erroring if the inputs #' to getClusterSelMatrix are invalid. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetClusterSelMatrixInput <- function(clusters, res){ stopifnot(is.matrix(res)) stopifnot(all(res %in% c(0, 1))) p <- ncol(res) stopifnot(nrow(res) > 0) checkClusters(clusters, p) } "],["sel-and-pred.html", "4 Selection and prediction functions", " 4 Selection and prediction functions Now that css() has been defined, we write functions to work with the output of css(). The output of these functions will be of more direct interest for most end users than the output of css(). These functions are defined separately from css() because the most computationally intensive steps happen within css(). css() can be called only once on a data set, and then the functions that follow can be explored relatively quickly (one can try different parameters, etc.). getCssSelections() takes in the results of css() along with user-defined parameters on how to select clusters (a minimum or maximum number of clusters to select, along with a cutoff for cluster selection proportions) and selects clusters as well as features from those clusters. getCssDesign() takes in the same inputs as getCssSelections() along with an unlabeled test matrix of features X (containing the same features as the X matrix provided originally to css()). It uses the results from css() to select clusters like getCssSelections(), then it uses a user-selected weighting scheme to compute weighted averages of the cluster members. It returns a test matrix of cluster representatives, which can be used for downstream predictive tasks. Finally, getCssPreds() has the same inputs as getCssDesign(), except it also accepts a set of labeled training data (where the response must be real-valued). getCssPreds() selects clusters, forms matrices of cluster representatives on the training and test data, uses the training matrix of cluster representatives (along with the vector of responses for the training data) to estimate a linear model via ordinary least squares, and finally generates predictions on the test data using this linear model. As in the previous section, we first define each function and then define the helper functions called by that function. As before, the tests for these functions are collected in the Tests chapters at the end of this document (the Tests part). getCssSelections() Calls checkCutoff(), which checks that the specified cutoff input is as expected checkWeighting() verifies the weighting input to getCssSelections() checkMinNumClusts() confirms that the min_num_clusts parameter provided to getCssSelections() is as expected Likewise for checkMaxNumClusts() getSelectedClusters() is the workhorse function of getCssSelections(), doing most of the work to get the selected clusters (and the selected features from those clusters) with the verified inputs checkSelectedClusters() checks internally that the selected clusters are as expected getAllClustWeights() gets the weights for each of the members of the selected clusters getClustWeights() gets the weights for a single cluster checkGetSelectedClustersOutput() verifies the output of getSelectedClusters() getCssDesign() checkNewXProvided() confirms that the design matrix provided to getCssDesign() matches the characteristics of the matrix that was provided to css(). checkXInputResults() also verifies these inputs (and is also used by getCssPreds() on both the training and test data) formCssDesign() is the workhorse function, generating a matrix of cluster representatives with the verified inputs to getCssDesign() checkFormCssDesignInputs() verifies the inputs to formCssDesign() (somewhat redundantly here, but formCssDesign() is called by more than one function, so this verifies the inputs to formCssDesign() regardless of where it is called). getCssPreds() checkGetCssPredsInputs() verifies the inputs to getCssPreds() getCssSelections(): #' Obtain a selected set of clusters and features #' #' Generate sets of selected clusters and features from cluster stability #' selection. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. #' (Exception: if no member of a selected cluster was selected on any subsample, #' the weights fall back to a simple average, so all of that cluster's members #' are returned.) For "simple_avg", each cluster #' member gets equal weight regardless of the individual feature selection #' proportions (that is, all cluster members within each selected cluster will #' be returned.). See Faletto and Bien (2022) for details. Default is "sparse". #' @param cutoff Numeric; getCssSelections will select and return only of those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are selected, or #' max_num_clusts are selected, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow #' a pure cutoff-based (threshold) selection that returns an empty set when no #' cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A named list with three items. \\item{selected_clusts}{A named list of #' integer vectors; each vector contains the indices of the features in one of #' the selected clusters.} \\item{selected_feats}{A named integer vector; the #' indices of the features with nonzero weights from all of the selected #' clusters.} \\item{weights}{A named list of the same length as selected_clusts. #' Each list element `weights[[j]]` is a numeric vector of the weights to use for #' the jth selected cluster, and it has the same name as the cluster it #' corresponds to.} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' getCssSelections(res) #' @export getCssSelections <- function(css_results, weighting="sparse", cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) checkCutoff(cutoff) checkWeighting(weighting) p <- ncol(css_results$feat_sel_mat) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) sel_results <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts) # sel_results$selected_clusts is guaranteed to have length at least 1 by # getSelectedClusters sel_clust_names <- names(sel_results$selected_clusts) stopifnot(length(sel_clust_names) >= 0) stopifnot(all(sel_clust_names %in% names(css_results$clusters))) sel_clusts <- list() for(i in seq_along(sel_clust_names)){ sel_clusts[[i]] <- css_results$clusters[[sel_clust_names[i]]] names(sel_clusts)[i] <- sel_clust_names[i] } stopifnot(is.list(sel_clusts)) stopifnot(length(sel_clusts) == length(sel_clust_names)) # sel_results$selected_feats is guaranteed to have length at least as long # as sel_results$selected_clusts by getSelectedClusters return(list(selected_clusts=sel_clusts, selected_feats=sel_results$selected_feats, weights=sel_results$weights)) } checkCutoff(): #' Helper function to confirm that the argument cutoff to several functions is #' as expected #' #' @param cutoff Numeric; only those clusters with selection proportions equal #' to at least cutoff will be selected by cluster stability selection. Must be #' between 0 and 1. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCutoff <- function(cutoff){ stopifnot(is.numeric(cutoff) | is.integer(cutoff)) stopifnot(length(cutoff) == 1) stopifnot(!is.na(cutoff)) stopifnot(cutoff >= 0) stopifnot(cutoff <= 1) } checkWeighting(): #' Helper function to confirm that the argument weighting to several #' functions is as expected #' #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkWeighting <- function(weighting){ stopifnot(length(weighting)==1) stopifnot(!is.na(weighting)) if(!is.character(weighting)){ stop("Weighting must be a character") } if(!(weighting %in% c("sparse", "simple_avg", "weighted_avg"))){ stop("Weighting must be a character and one of sparse, simple_avg, or weighted_avg") } } checkMinNumClusts(): #' Helper function to confirm that the argument min_num_clusts to several #' functions is as expected #' #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param p The number of features; since this is an upper bound on the number #' of clusters of features, it is also an upper bound on min_num_clusts. #' @param n_clusters The number of clusters; note that this is an upper bound #' on min_num_clusts #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkMinNumClusts <- function(min_num_clusts, p, n_clusters){ stopifnot(length(min_num_clusts) == 1) stopifnot(is.numeric(min_num_clusts) | is.integer(min_num_clusts)) stopifnot(!is.na(min_num_clusts)) stopifnot(min_num_clusts == round(min_num_clusts)) stopifnot(min_num_clusts >= 0) stopifnot(min_num_clusts <= p) stopifnot(min_num_clusts <= n_clusters) } checkMaxNumClusts(): #' Helper function to confirm that the argument max_num_clusts to several #' functions is as expected #' #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Can be NA, in which case #' max_num_clusts will be ignored. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) max_num_clusts must be at least as #' large as min_num_clusts. #' @param p The number of features; since this is an upper bound on the number #' of clusters of features, it is also an upper bound on max_num_clusts. #' @param n_clusters The number of clusters; note that this is an upper bound #' on max_num_clusts #' @return The provided max_num_clusts, coerced to an integer if needed, and #' coerced to be less than or equal to the total number of clusters. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkMaxNumClusts <- function(max_num_clusts, min_num_clusts, p, n_clusters){ stopifnot(length(max_num_clusts) == 1) if(!is.na(max_num_clusts)){ stopifnot(is.numeric(max_num_clusts) | is.integer(max_num_clusts)) stopifnot(max_num_clusts == round(max_num_clusts)) stopifnot(max_num_clusts >= 1) stopifnot(max_num_clusts <= p) max_num_clusts <- as.integer(min(n_clusters, max_num_clusts)) stopifnot(max_num_clusts >= min_num_clusts) } return(max_num_clusts) } getSelectedClusters(): #' From css output, obtain names of selected clusters and selection proportions, #' indices of all selected features, and weights of individual cluster members #' #' If cutoff is too high for at least min_num_clusts clusters to be selected, #' then it will be lowered until min_num_clusts can be selected. After that, if #' the cutoff is too low such that more than max_num_clusts are selected, then #' the cutoff will be increased until no more than max_num_clusts are selected. #' Note that because clusters can have tied selection proportions, it is #' possible that the number of selected clusters will be strictly lower than #' max_num_clusts or strictly greater than min_num_clusts. In fact, it is #' possible that both cutoffs won't be able to be satisfied simulteaneously, #' even if there is a strictly positive difference between max_num_clusts and #' min_num_clusts. If this occurs, max_num_clusts will take precedence over #' min_num_clusts. getSelectedClusters will throw an error if the provided #' inputs don't allow it to select any clusters. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @param cutoff Numeric; getCssSelections will select and return only of those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored. #' @return A named list with the following elements: \\item{selected_clusts}{A #' named numeric vector containing the selection proportions for the selected #' clusters. The name of each entry is the name of the corresponding cluster.} #' \\item{selected_feats}{A named integer vector; the indices of the features #' with nonzero weights from all of the selected clusters.} \\item{weights}{A #' named list of the same length as the number of selected clusters. Each list #' element `weights[[j]]` is a numeric vector of the weights to use for the jth #' selected cluster, and it has the same name as the cluster it corresponds #' to.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectedClusters <- function(css_results, weighting, cutoff, min_num_clusts, max_num_clusts){ # Check input stopifnot(inherits(css_results, "cssr")) # Eliminate clusters with selection proportions below cutoff clus_sel_props <- colMeans(css_results$clus_sel_mat) B <- nrow(css_results$feat_sel_mat) # Selection proportions are exact multiples of 1/B; work in integer count # space so the documented ">= cutoff" holds exactly (no float snapping) and # the loop thresholds step by whole counts (retires the #42 class). (#159a) counts <- round(clus_sel_props * B) thresh <- ceiling(cutoff * B - 1e-9) # Get selected clusters selected_clusts <- clus_sel_props[counts >= thresh] # Check that selected_clusts has length at least min_num_clusts while(length(selected_clusts) < min_num_clusts){ # Guard against an unbounded decrement if min_num_clusts exceeds the # number of clusters: once every cluster is selected we can't select # more, so stop (mirrors the max-loop's break) (#69). Unreachable via the # public API (checkMinNumClusts enforces min_num_clusts <= n_clusters), # but a defensive break for any internal caller. if(length(selected_clusts) == length(clus_sel_props)){ break } thresh <- thresh - 1L selected_clusts <- clus_sel_props[counts >= thresh] } # Check that selected_clusts has length at most max_num_clusts if(!is.na(max_num_clusts)){ while(length(selected_clusts) > max_num_clusts){ thresh <- thresh + 1L # Once the threshold exceeds B no count can meet it, so stop before # emptying the selection (retires the #42 float-accumulation break). if(thresh > B){ break } # Make sure we don't reduce to a selected set of size 0 if(any(counts >= thresh)){ selected_clusts <- clus_sel_props[counts >= thresh] } else{ break } } } stopifnot(length(selected_clusts) >= 0) clust_names <- names(selected_clusts) n_sel_clusts <- length(selected_clusts) # Check that n_sel_clusts is as expected, and throw warnings or an error if # not checkSelectedClusters(n_sel_clusts, min_num_clusts, max_num_clusts, max(clus_sel_props)) ### Get selected features from selected clusters clusters <- css_results$clusters stopifnot(all(clust_names %in% names(clusters))) # Get a list of weights for all of the selected clusters weights <- getAllClustWeights(css_results, selected_clusts, weighting) # Get selected features from each cluster (those features with nonzero # weights) selected_feats <- integer() for(i in seq_len(n_sel_clusts)){ clus_i_name <- clust_names[i] clust_i <- clusters[[clus_i_name]] weights_i <- weights[[i]] selected_feats <- c(selected_feats, clust_i[weights_i != 0]) } feat_names <- colnames(css_results$feat_sel_mat) names(selected_feats) <- feat_names[selected_feats] # Check output (already checked weights wihin getAllClustWeights) checkGetSelectedClustersOutput(selected_clusts, selected_feats, weights, n_clusters=length(clusters), p=ncol(css_results$feat_sel_mat)) return(list(selected_clusts=selected_clusts, selected_feats=selected_feats, weights=weights)) } checkSelectedClusters(): #' Helper function to check operations within getSelectedClusters function #' #' @param n_sel_clusts The number of selected clusters; should be constrained #' by min_num_clusts and max_num_clusts (though it may not be possible to #' satisfy both constraints simulteneously, in which case a warning will be #' thrown). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored. #' @param max_sel_prop Numeric; the maximum selection proportion observed for #' any cluster. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkSelectedClusters <- function(n_sel_clusts, min_num_clusts, max_num_clusts, max_sel_prop){ if(n_sel_clusts == 0 && min_num_clusts >= 1){ err <- paste("No clusters selected with this cutoff (try a cutoff below the maximum cluster selection proportion, ", max_sel_prop, ")", sep="") stop(err) } stopifnot(n_sel_clusts >= 0) # It may be impossible to get at least min_num_clusts or at most # max_num_clusts; if so, give a warning if(n_sel_clusts < min_num_clusts){ warn <- paste("Returning fewer than min_num_clusts = ", min_num_clusts, " clusters because decreasing the cutoff any further would require returning more than max_num_clusts = ", max_num_clusts, " clusters", sep="") warning(warn) } if(!is.na(max_num_clusts)){ if(n_sel_clusts > max_num_clusts){ warn <- paste("Returning more than max_num_clusts = ", max_num_clusts, " clusters because increasing the cutoff any further would require returning 0 clusters", sep="") warning(warn) } } } getAllClustWeights(): #' Calculate weights for each cluster member of all of the selected clusters. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param sel_clusters A named numeric vector containing the selection #' proportions for the selected clusters. The name of each entry is the name #' of the corresponding cluster. #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @return A named list of the same length as sel_clusters of numeric vectors. #' `weights[[j]]` is the weights to use for the jth selected cluster, and it has #' the same name as the cluster it corresponds to. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getAllClustWeights <- function(css_results, sel_clusters, weighting){ # Check inputs stopifnot(inherits(css_results, "cssr")) stopifnot(is.numeric(sel_clusters)) p_ret <- length(sel_clusters) stopifnot(length(unique(names(sel_clusters))) == p_ret) stopifnot(p_ret >= 0) checkWeighting(weighting) # Get selection proportions and clusters feat_sel_props <- colMeans(css_results$feat_sel_mat) p <- length(feat_sel_props) stopifnot(p >= p_ret) clusters <- css_results$clusters stopifnot(all(names(sel_clusters) %in% names(clusters))) # Identify weights weights <- list() for(j in seq_len(p_ret)){ # Find the members of the cluster feature j is a member of cluster_j <- clusters[[names(sel_clusters)[j]]] # Get the weights for this cluster and add them to the list weights[[j]] <- getClustWeights(cluster_j, weighting, feat_sel_props) } # Add names to weights names(weights) <- names(sel_clusters) # Check output stopifnot(length(weights) == p_ret) stopifnot(is.list(weights)) for(i in seq_len(p_ret)){ stopifnot(length(clusters[[names(sel_clusters)[i]]]) == length(weights[[i]])) stopifnot(all(weights[[i]] >= 0)) stopifnot(all(weights[[i]] <= 1)) stopifnot(abs(sum(weights[[i]]) - 1) < 10^(-6)) } return(weights) } getClustWeights(): #' Calculate weights for members of a cluster using selection proportions #' #' Given a cluster of features, the selection proportions for each cluster #' member, and a specified weighting scheme, calculate the appropriate weights #' for the cluster. #' @param cluster_i An integer vector containing the indices of the members #' of a cluster. #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @param feat_sel_props A numeric vector of selection proportions corresponding #' to each of the p features. #' @return A numeric vector of the same length as cluster_i containing the #' weights corresponding to each of the features in cluster_i. The weights #' will all be nonnegative and sum to 1. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getClustWeights <- function(cluster_i, weighting, feat_sel_props){ stopifnot(is.integer(cluster_i) | is.numeric(cluster_i)) stopifnot(all(cluster_i == round(cluster_i))) n_weights <- length(cluster_i) stopifnot(length(unique(cluster_i)) == n_weights) p <- length(feat_sel_props) stopifnot(all(cluster_i %in% 1:p)) # Get the selection proportions of each cluster member sel_props <- feat_sel_props[cluster_i] stopifnot(all(sel_props >= 0)) stopifnot(all(sel_props <= 1)) weights_i <- rep(as.numeric(NA), n_weights) # Weighted or simple average? if(weighting == "sparse"){ # Sparse cluster stability selection: All features in cluster with # selection proportion equal to the max # for the cluster get equal weight; rest of cluster gets 0 weight if(sum(sel_props) == 0){ weights_i <- rep(1/n_weights, n_weights) } else{ maxes <- sel_props==max(sel_props) stopifnot(sum(maxes) > 0) stopifnot(sum(maxes) <= n_weights) weights_i <- rep(0, n_weights) weights_i[maxes] <- 1/sum(maxes) } } else if(weighting == "weighted_avg"){ # Get weights for weighted average if(sum(sel_props) == 0){ weights_i <- rep(1/n_weights, n_weights) } else{ weights_i <- sel_props/sum(sel_props) } } else if(weighting == "simple_avg"){ weights_i <- rep(1/n_weights, n_weights) } else{ stop("weighting must be one of sparse, simple_avg, or weighted_avg") } stopifnot(abs(sum(weights_i) - 1) < 10^(-6)) stopifnot(length(weights_i) == n_weights) stopifnot(length(weights_i) >= 1) stopifnot(all(weights_i >= 0)) stopifnot(all(weights_i <= 1)) return(weights_i) } checkGetSelectedClustersOutput(): #' Helper function to check that output of getSelectedClusters is as expected #' #' @param selected_clusts A named numeric vector containing the selection #' proportions for the selected clusters. The name of each entry is the name of #' the corresponding cluster. #' @param selected_feats A named integer vector; the indices of the features #' with nonzero weights from all of the selected clusters. #' @param weights A named list of the same length as the number of selected #' clusters. Each list element `weights[[j]]` is a numeric vector of the weights #' to use for the jth selected cluster, and it has the same name as the cluster #' it corresponds to. #' @param n_clusters Integer; the number of clusters in the data (upper bound #' for the length of selected_clusts) #' @param p Integer; number of features in the data (all selected_feats should #' be in 1:p) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetSelectedClustersOutput <- function(selected_clusts, selected_feats, weights, n_clusters, p){ stopifnot(is.numeric(selected_clusts)) stopifnot(all(selected_clusts >= 0)) stopifnot(all(selected_clusts <= 1)) stopifnot(length(selected_clusts) >= 0) stopifnot(length(selected_clusts) <= n_clusters) stopifnot(length(names(selected_clusts)) == length(unique(names(selected_clusts)))) stopifnot(!is.null(names(selected_clusts))) stopifnot(all(!is.na(names(selected_clusts)) & names(selected_clusts) != "")) stopifnot(length(names(selected_clusts)) == length(selected_clusts)) stopifnot(is.integer(selected_feats)) stopifnot(length(selected_feats) == length(unique(selected_feats))) stopifnot(all(selected_feats %in% 1:p)) stopifnot(length(selected_clusts) <= length(selected_feats)) stopifnot(identical(names(weights), names(selected_clusts))) stopifnot(length(weights) == length(selected_clusts)) } getCssDesign() #' Obtain a design matrix of cluster representatives #' #' Takes a matrix of observations from the original feature space and returns #' a matrix of representatives from the selected clusters based on the results #' of cluster stability selection. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param newX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newX are labeled, the names must match the variable names provided to css. #' Must not contain missing (`NA`) values. newX may be omitted if train_inds #' were provided to css to set aside observations for model estimation. If this #' is the case, then when newX is omitted getCssDesign will return a design #' matrix of cluster representatives formed from the train_inds observations #' from the matrix X provided to css. (If no train_inds were provided to css, #' newX must be provided to getCssDesign.) Default is NA. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssDesign will only include those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty #' selection then raises an error (no design/predictions possible). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A design matrix with either nrow(newX) (or length(train_inds), if #' train_inds was provided to css and newX was not provided to getCssDesign) #' observations and number of columns equal to the number of selected clusters, #' containing the cluster representatives for each cluster. #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' train <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' newdata <- genClusteredData(n = 10, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = train$X, y = train$y, lambda = 0.01, clusters = clusters, #' B = 10) #' X_design <- getCssDesign(res, newX = newdata$X) #' dim(X_design) #' @export getCssDesign <- function(css_results, newX=NA, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) check_results <- checkNewXProvided(newX, css_results) newX <- check_results$newX newXProvided <- check_results$newXProvided rm(check_results) # #142: checkNewXProvided returns newX with its (already css-validated) column # names stripped (via checkXInputResults). Re-attach them from css_results$X # (which they were validated to match; ncol(newX) == ncol(css_results$X) for a # provided input) so the checkXInputResults call below does not spuriously warn # on a data.frame newX. Names never enter the numeric design. if(newXProvided && !is.null(colnames(css_results$X))){ colnames(newX) <- colnames(css_results$X) } n_train <- nrow(newX) results <- checkXInputResults(newX, css_results$X) newX <- results$newx feat_names <- results$feat_names # #142: re-attach newX's (already css-validated) column names that # checkXInputResults strips, so the downstream formCssDesign(newx=newX) call # doesn't spuriously warn on a data.frame newX. Names never enter the numeric # design (formCssDesign strips + builds cluster reps positionally), so this # only silences the warning; mirrors the getCssPreds fix. if(all(!is.na(feat_names))){ colnames(newX) <- feat_names } rm(results) n <- nrow(newX) p <- ncol(newX) checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) # Take provided training design matrix and testX and turn them into # matrices of cluster representatives using information from css_results if(newXProvided){ newX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=newX) } else{ newX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts) } return(newX_clusters) } checkNewXProvided() #' Helper function to confirm that the new X matrix provided to getCssDesign or #' getCssPreds matches the characteristics of the X that was provided to css. #' #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix). Must contain #' the same features (in the same number of columns) as the X matrix provided to #' css, and if the columns of trainX are labeled, the names must match the #' variable names provided to css. trainX may be omitted if train_inds were #' provided to css to set aside observations. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @return A named list with the following elements: \\item{newX}{If trainX was #' provided, this is the provided trainX matrix, coerced from a data.frame to a #' matrix if the provided trainX was a data.frame. If trainX was not provided, #' this is a matrix made up of the training indices provided to css in the #' train_inds argument.} \\item{newXProvided}{Logical; indicates whether a valid #' trainX input was provided.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkNewXProvided <- function(trainX, css_results){ newXProvided <- FALSE # trainX's own validated column names, captured from checkXInputResults so # the caller (checkGetCssPredsInputs, #153a) can restore them independently # of testX. NA for the not-provided/train_inds branch, where names are # irrelevant. trainX_feat_names <- as.character(NA) # "Was newX provided?" -- the documented default for trainX is the scalar NA # sentinel, so treat trainX as provided UNLESS it is exactly that default # (an atomic, length-1 NA). A previous length()-based heuristic # (length(trainX) > 1) misclassified a numeric vector or a one-column # data.frame (length 1) as "not provided" and silently fell back to # train_inds. The is.atomic/length/is.na test instead routes any matrix or # data.frame to the provided branch -- including an NA-CONTAINING matrix # (length > 1, so the is.na operand is short-circuited and never collapses a # multi-element matrix to a length-1 logical), which is then rejected by # checkXInputResults' checkNoNAs rather than silently replaced by the # train_inds data (#71). if(!(is.atomic(trainX) && length(trainX) == 1 && is.na(trainX))){ # trainX was provided -- it must be a matrix or data.frame (a bare # vector is not a valid design and used to fail with a cryptic # is.matrix() stopifnot downstream). if(!(is.matrix(trainX) || is.data.frame(trainX))){ stop("newX must be a matrix or data.frame with the same columns as the X provided to css().", call. = FALSE) } newXProvided <- TRUE xres <- checkXInputResults(trainX, css_results$X) trainX <- xres$newx trainX_feat_names <- xres$feat_names rm(xres) n_train <- nrow(trainX) # A single-row newX is fine -- the design is just one row of cluster # representatives, and getCssPreds/cssPredict already accept a 1-row test # set -- so don't require more than one row here (#44). stopifnot(n_train >= 1) } else{ if(length(css_results$train_inds) == 0){ stop("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") } trainX <- css_results$X[css_results$train_inds, , drop = FALSE] } stopifnot(is.matrix(trainX)) stopifnot(is.numeric(trainX) | is.integer(trainX)) stopifnot(all(!is.na(trainX))) stopifnot(ncol(trainX) >= 2) return(list(newX=trainX, newXProvided=newXProvided, feat_names=trainX_feat_names)) } checkXInputResults() #' Helper function to confirm that inputs to several functions are as expected, #' and modify inputs if needed #' #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newX are labeled, the names must match the variable names provided to css. #' @param css_X The X matrix provided to css, as in the output of the css #' function (after having been coerced from a data.frame to a matrix by css if #' needed). #' @return A named list with the following elements. \\item{feat_names}{A #' character vector containing the column names of newx (if the provided newx #' had column names). If the provided newx did not have column names, feat_names #' will be NA.} \\item{newx}{The provided newx matrix, coerced from a data.frame #' to a matrix if the provided newx was a data.frame.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkXInputResults <- function(newx, css_X){ checkNoNAs(newx, "newx") # Check if x is a matrix; if it's a data.frame, convert to matrix. newx <- coerceDataFrameToMatrix(newx, clusters = list(), arg_name = "newx") feat_names <- as.character(NA) if(!is.null(colnames(newx))){ feat_names <- colnames(newx) } else{ # In this case, newx has no column names, so same better be true of # css_X if(!is.null(colnames(css_X))){ warning("New X provided had no variable names (column names) even though the X provided to css did.") } } stopifnot(is.matrix(newx)) n <- nrow(newx) p <- ncol(newx) stopifnot(p >= 2) if(length(feat_names) > 1){ stopifnot(length(feat_names) == p) stopifnot(!("(Intercept)" %in% feat_names)) } else{ stopifnot(is.na(feat_names)) } colnames(newx) <- character() # Confirm that newx matches css_results$X if(p != ncol(css_X)){ err <- paste("Number of columns in newx must match number of columns from matrix provided to css. Number of columns in new provided X: ", p, ". Number of columns in matrix provided to css: ", ncol(css_X), ".", sep="") stop(err) } if(length(feat_names) != 1 & all(!is.na(feat_names))){ if(!identical(feat_names, colnames(css_X))){ stop("Provided feature names for newx do not match feature names provided to css") } } return(list(feat_names=feat_names, newx=newx)) } formCssDesign(): #' Create design matrix of cluster representatives from matrix of raw features #' using results of css function #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; css will return only those clusters with selection #' proportions equal to at least cutoff. Must be between 0 and 1. Default is 0 #' (in which case all clusters are returned in decreasing order of selection #' proportion). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newx are labeled, the names must match the variable names provided to css. #' newx may be omitted if train_inds were provided to css to set aside #' observations for model estimation. If this is the case, then when newx is #' omitted formCssDesign will return a design matrix of cluster representatives #' formed from the train_inds observations from the matrix X provided to css. #' (If no train_inds were provided to css, newX must be provided to #' formCssDesign.) Default is NA. #' @return A design matrix with the same number of rows as newx (or the #' train_inds provided to css) where the columns are the constructed cluster #' representatives. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @keywords internal #' @noRd formCssDesign <- function(css_results, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA, newx=NA, weights=NULL, validated=FALSE){ # Check inputs ret <- checkFormCssDesignInputs(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx, validated = validated) newx <- ret$newx max_num_clusts <- ret$max_num_clusts rm(ret) n <- nrow(newx) p <- ncol(newx) # Get the names of the selected clusters and the weights for the features # within each cluster, according to the provided weighting rule. These depend # only on css_results and the (weighting, cutoff, min/max_num_clusts) args, # NOT on newx, so a caller that forms several designs from one css_results # (e.g. getCssPreds, which builds a train design and a test design) can # compute them once and pass them in via `weights` to skip the repeated # getSelectedClusters() work. Byte-identical: a passed-in `weights` equals # what this call would otherwise recompute (checkMaxNumClusts is idempotent, # so the max_num_clusts re-derived by checkFormCssDesignInputs above matches # the caller's already-adjusted value). (#129) if(is.null(weights)){ weights <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts)$weights } n_sel_clusts <- length(weights) if(n_sel_clusts == 0){ stop("No clusters were selected, so a design matrix / predictions cannot be formed; lower the cutoff or set min_num_clusts >= 1.") } # Form matrix of cluster representatives of selected clusters X_clus_reps <- matrix(rep(as.numeric(NA), n*n_sel_clusts), nrow=n, ncol=n_sel_clusts) colnames(X_clus_reps) <- rep(as.character(NA), n_sel_clusts) for(i in seq_len(n_sel_clusts)){ clust_i_name <- names(weights)[i] stopifnot(length(clust_i_name) == 1) stopifnot(clust_i_name %in% names(weights)) colnames(X_clus_reps)[i] <- clust_i_name clust_i <- css_results$clusters[[clust_i_name]] stopifnot(length(clust_i) >= 1) stopifnot(all(clust_i %in% 1:p)) weights_i <- weights[[clust_i_name]] stopifnot(length(clust_i) == length(weights_i)) if(length(weights_i) > 1){ X_clus_reps[, i] <- newx[, clust_i] %*% weights_i } else{ X_clus_reps[, i] <- newx[, clust_i]*weights_i } } # Check output stopifnot(all(!is.na(X_clus_reps))) stopifnot(ncol(X_clus_reps) == n_sel_clusts) stopifnot(nrow(X_clus_reps) == n) return(X_clus_reps) } checkFormCssDesignInputs(): #' Helper function to check that the inputs to formCssDesign are as expected #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". #' @param cutoff Numeric; css will return only those clusters with selection #' proportions equal to at least cutoff. Must be between 0 and 1. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newx are labeled, the names must match the variable names provided to css. #' newx may be omitted if train_inds were provided to css to set aside #' observations for model estimation. If this is the case, then when newx is #' omitted formCssDesign will return a design matrix of cluster representatives #' formed from the train_inds observations from the matrix X provided to css. #' (If no train_inds were provided to css, newX must be provided to #' formCssDesign.) #' @return A named list with the following elements: \\item{newx}{If newx was #' provided, the provided newx matrix, coerced from a data.frame to a matrix if #' needed. If newx was not provided, a matrix formed by the train_inds set #' aside in the original function call to css.} \\item{max_num_clusts}{The #' provided max_num_clusts, coerced to an integer if needed, and coerced to be #' less than or equal to the total number of clusters.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkFormCssDesignInputs <- function(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx, validated=FALSE){ stopifnot(inherits(css_results, "cssr")) if(length(newx) == 1 && is.na(newx)){ if(length(css_results$train_inds) == 0){ stop("If css was not provided with indices to set aside for model training, then newx must be provided to formCssDesign") } newx <- css_results$X[css_results$train_inds, , drop = FALSE] } else if(validated){ # newx already validated + coerced by the caller (getCssPreds via # checkGetCssPredsInputs); skip the redundant checkXInputResults that # otherwise re-emits the same name/NA warnings up to 4x/call (#153b). stopifnot(is.matrix(newx)) } else{ results <- checkXInputResults(newx, css_results$X) newx <- results$newx rm(results) } p <- ncol(newx) checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) return(list(newx=newx, max_num_clusts=max_num_clusts)) } getCssPreds() #' Fit model and generate predictions from new data #' #' Generate predictions on test data using cluster stability-selected model. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param testX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as the matrix provided to css, and #' if the columns of testX are labeled, the names must match the variable names #' provided to css. Must not contain missing (`NA`) values. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssPreds will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty #' selection then raises an error (no design/predictions possible). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to estimate the linear model from the selected #' clusters. trainX is only necessary to provide if no train_inds were #' designated in the css function call to set aside observations for model #' estimation (though even if train_inds was provided, trainX and trainY will be #' used for model estimation if they are both provided to getCssPreds). Must #' contain the same features (in the same number of columns) as the matrix #' provided to css, and if the columns of trainX are labeled, the names must #' match the variable names provided to css. Must not contain missing (`NA`) #' values. Default is NA (in which case getCssPreds uses the observations from #' the train_inds that were provided to css to estimate a linear model). #' @param trainY The response corresponding to trainX. Must be a real-valued #' response (unlike in the general css setup) because predictions will be #' generated by an ordinary least squares model. Must have the same length as #' the number of rows of trainX. Like trainX, only needs to be provided if no #' observations were set aside for model estimation by the parameter train_inds #' in the css function call. Default is NA (in which case getCssPreds uses the #' observations from the train_inds that were provided to css). #' @return A vector of predictions corresponding to the observations from testX. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredData(n = 60, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' # Split into selection / training / test rows. #' res <- css(X = data$X[1:20, ], y = data$y[1:20], lambda = 0.01, #' clusters = clusters, B = 10) #' preds <- getCssPreds(res, testX = data$X[51:60, ], #' trainX = data$X[21:50, ], trainY = data$y[21:50]) #' preds #' @export getCssPreds <- function(css_results, testX, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA, trainX=NA, trainY=NA){ # Check inputs check_list <- checkGetCssPredsInputs(css_results, testX, weighting, cutoff, min_num_clusts, max_num_clusts, trainX, trainY) trainXProvided <- check_list$trainXProvided trainX <- check_list$trainX testX <- check_list$testX feat_names <- check_list$feat_names max_num_clusts <- check_list$max_num_clusts rm(check_list) n_train <- nrow(trainX) n <- nrow(testX) p <- ncol(testX) # The cluster weights depend only on css_results and the (weighting, cutoff, # min/max_num_clusts) arguments -- not on the design matrix -- so compute # them ONCE here and reuse for every formCssDesign() call below (train + # test) instead of letting each call recompute the same getSelectedClusters() # (colMeans + cutoff loops + getAllClustWeights). max_num_clusts is already # checkMaxNumClusts-adjusted by checkGetCssPredsInputs, and checkMaxNumClusts # is idempotent, so these weights are byte-identical to what each # formCssDesign() would otherwise compute internally. (#129) sel_weights <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts)$weights # Take provided training design matrix and testX and turn them into # matrices of cluster representatives using information from css_results if(trainXProvided){ train_X_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=trainX, weights=sel_weights, validated=TRUE) if(!is.numeric(trainY) & !is.integer(trainY)){ stop("The provided trainY must be real-valued, because predictions will be generated by ordinary least squares regression.") } y_train <- trainY } else{ train_X_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, weights=sel_weights, validated=TRUE) y_train <- css_results$y[css_results$train_inds] if(!is.numeric(y_train) & !is.integer(y_train)){ stop("Can't generate predictions from the data that was provided to css because the provided y was not real-valued (getCssPreds generated predictions using ordinary least squares regression).") } } stopifnot(length(y_train) == nrow(train_X_clusters)) testX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=testX, weights=sel_weights, validated=TRUE) stopifnot(ncol(testX_clusters) == ncol(train_X_clusters)) # Get names for clusters clust_X_names <- paste("c_fit_", 1:ncol(testX_clusters), sep="") if(!is.null(colnames(train_X_clusters))){ stopifnot(identical(colnames(train_X_clusters), colnames(testX_clusters))) clust_X_names <- colnames(train_X_clusters) } # Fit linear model on training data via OLS. lm(y ~ .) adds an intercept, so # the fit is rank-deficient unless there are strictly more training # observations than clusters (nrow >= ncol + 1); guard with <= so the # n_train == n_clusters boundary errors clearly instead of silently fitting a # rank-deficient model with NA coefficients. if(nrow(train_X_clusters) <= ncol(train_X_clusters)){ err_mess <- paste("css not provided with enough indices to fit OLS model for predictions (number of training indices: ", nrow(train_X_clusters), ", number of clusters: ", ncol(train_X_clusters), "). The OLS model includes an intercept, so it needs at least one more training observation than the number of clusters. Try reducing number of clusters by increasing cutoff, or re-run css with a larger number of training indices.", sep="") stop(err_mess) } # Response name guaranteed distinct from every cluster name (issue #150): # make.unique returns "y" when no cluster is named "y" (bit-identical to # prior behavior) and e.g. "y.1" when one is, so lm() never drops a # cluster representative via a name collision with the response. resp_name <- make.unique(c(clust_X_names, "y"))[length(clust_X_names) + 1L] df <- data.frame(y_train, train_X_clusters) colnames(df) <- c(resp_name, clust_X_names) stopifnot(!anyDuplicated(colnames(df))) model <- stats::lm(stats::as.formula(paste0("`", resp_name, "` ~ .")), data = df) # Use fitted model to generate predictions on testX. Route through # olsPredictRankSafe() so a rank-deficient OLS fit predicts from its # estimable coefficients instead of crashing under R >= 4.4's predict.lm # default (see the helper's note and issue #117). df_test <- data.frame(testX_clusters) colnames(df_test) <- clust_X_names predictions <- olsPredictRankSafe(model, df_test) names(predictions) <- NULL # Check output stopifnot(is.numeric(predictions) | is.integer(predictions)) stopifnot(length(predictions) == n) stopifnot(all(is.finite(predictions))) return(predictions) } Internal OLS-prediction helper used by getCssPreds() (issue #117): #' Predict from a possibly rank-deficient OLS fit without crashing on R >= 4.4 #' #' On R >= 4.4 `stats::predict.lm()`'s default `rankdeficient = "warnif"` runs #' `qr.Q(qr.default(t(qr.R(model$qr))))`, which aborts with "NA/NaN/Inf in #' foreign function call" when `qr.R(model$qr)` contains NaN/Inf (a rank-deficient #' fit plus a LINPACK numerical pathology seen on real high-dimensional data). #' `rankdeficient = "simple"` restores the pre-4.4 behavior: predict from the #' estimable coefficients, yielding finite predictions. That argument only exists #' on R >= 4.4, so it is added conditionally (a plain retry with the argument #' would itself error on older R with "unused argument"). The `"simple"` path #' emits the stock "rank-deficient fit" warning; muffle only that specific #' warning (its advice to use `rankdeficient = "NA"` would NA-fill non-estimable #' cases and break the finiteness contract in `getCssPreds()`) so unrelated #' warnings still surface. On full-rank fits this is bit-identical to the old #' default. #' @noRd olsPredictRankSafe <- function(model, newdata) { pred_args <- list(object = model, newdata = newdata) if (getRversion() >= "4.4.0") { pred_args$rankdeficient <- "simple" } withCallingHandlers( do.call(stats::predict.lm, pred_args), warning = function(w) { if (grepl("rank-deficient fit", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } } ) } checkGetCssPredsInputs(): #' Helper function to confirm that inputs to the function getCssPreds are as #' expected, and modify inputs if needed. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param testX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as the matrix provided to css. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the clusters #' that are tied for the top selection proportion if there is a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssPreds will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to estimate the linear model from the selected #' clusters. trainX is only necessary to provide if no train_inds were #' designated in the css function call to set aside observations for model #' estimation (though even if train_inds was provided, trainX and trainY will be #' used for model estimation if they are both provided to getCssPreds). Must #' contain the same features (in the same number of columns) as the matrix #' provided to css, and if the columns of trainX are labeled, the names must #' match the variable names provided to css. Must not contain missing (`NA`) #' values. Default is NA (in which case getCssPreds uses the observations from #' the train_inds that were provided to css to estimate a linear model). #' @param trainY The response corresponding to trainX. Must be a real-valued #' response (unlike in the general css setup) because predictions will be #' generated by an ordinary least squares model. Must have the same length as #' the number of rows of trainX. Like trainX, only needs to be provided if no #' observations were set aside for model estimation by the parameter train_inds #' in the css function call. Default is NA (in which case getCssPreds uses the #' observations from the train_inds that were provided to css). #' @return A named list with the following elements: \\item{trainXProvided}{ #' Logical; indicates whether a valid trainX input was provided.} \\item{trainX}{ #' The provided trainX matrix, coerced from a data.frame to a matrix if the #' provided trainX was a data.frame. (If a valid trainX was not provided, this #' output simply passes whatever was provided as trainX.)} \\item{testX}{The #' provided testX matrix, coerced from a data.frame to a matrix if the provided #' testX was a data.frame.} \\item{feat_names}{A character vector containing the #' column names of testX (if the provided testX had column names). If the #' provided testX did not have column names, feat_names will be NA.} #' \\item{max_num_clusts}{The provided max_num_clusts, coerced to an integer if #' needed, and coerced to be less than or equal to the total number of clusters #' from the output of css_results.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetCssPredsInputs <- function(css_results, testX, weighting, cutoff, min_num_clusts, max_num_clusts, trainX, trainY){ # Check inputs stopifnot(inherits(css_results, "cssr")) check_results <- checkNewXProvided(trainX, css_results) trainX <- check_results$newX trainXProvided <- check_results$newXProvided trainX_feat_names <- check_results$feat_names rm(check_results) n_train <- nrow(trainX) # #153d: distinguish an omitted trainY (documented scalar-NA default) from a # trainY that was PROVIDED but invalid (contains NA). The former falls back # to css's train_inds; the latter must error rather than silently switch the # data the model is fit on. trainYProvided <- !(is.atomic(trainY) && length(trainY) == 1 && is.na(trainY)) if(trainXProvided){ if(trainYProvided){ stopifnot(is.numeric(trainY)) if(any(is.na(trainY))){ stop("The provided trainY contains missing (NA) values; trainY must be a complete real-valued response with one value per row of trainX.") } stopifnot(n_train == length(trainY)) } else{ if(length(css_results$train_inds) == 0){ stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions") } trainXProvided <- FALSE warning("trainX provided but no trainY provided; instead, training model using the train_inds observations provided to css to set aside for model training.") } } else{ if(length(css_results$train_inds) == 0){ stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions") } if(trainYProvided){ warning("trainY provided but no trainX provided; instead, training model using the train_inds observations provided to css to set aside for model training.") } } results <- checkXInputResults(testX, css_results$X) testX <- results$newx feat_names <- results$feat_names if(all(!is.na(feat_names))){ stopifnot(length(feat_names) == ncol(testX)) stopifnot(!("(Intercept)" %in% feat_names)) colnames(testX) <- feat_names } rm(results) n <- nrow(testX) p <- ncol(testX) stopifnot(n >= 1) stopifnot(p == ncol(trainX)) # #153a: restore trainX's OWN validated names (checkNewXProvided strips them), # from the css object, independently of testX. The old #142 code derived them # from testX, so a named trainX + unnamed testX stayed name-less and tripped a # spurious downstream "no variable names" warning about a matrix the user named. if(trainXProvided && all(!is.na(trainX_feat_names))){ colnames(trainX) <- colnames(css_results$X) } # #153c: only compare names when trainX was USER-provided. Guarding here both # revives the previously-dead "testX but not trainX" branch (the old #142 # code always re-named trainX from testX, making it unsatisfiable) and # suppresses a false "trainX but not testX" warning on the train_inds default # path (where trainX is the internally-formed, unnamed train set). if(trainXProvided){ if(!is.null(colnames(trainX)) & is.null(colnames(testX))){ warning("Column names were provided for trainX but not for testX (are you sure they both contain identical features in the same order?)") } if(is.null(colnames(trainX)) & !is.null(colnames(testX))){ warning("Column names were provided for testX but not for trainX (are you sure they both contain identical features in the same order?)") } if(!is.null(colnames(trainX)) & !is.null(colnames(testX))){ stopifnot(all(colnames(trainX) == colnames(testX))) } } checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) return(list(trainXProvided=trainXProvided, trainX=trainX, testX=testX, feat_names=feat_names, max_num_clusts=max_num_clusts)) } "],["other-useful.html", "5 Other useful functions 5.1 Ergonomic S3 accessors: selected() and summary.cssr()", " 5 Other useful functions The following are some other functions that are useful for specific tasks. genClusteredData() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature (the latent features themselves are also provided), as in the simulation in Example 1, Section 5.1, and Section 5.2 of Faletto and Bien (2022). genClusteredDataWeighted() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature with unequal correlations (the latent features themselves are also provided), as in the simulation Section 5.3 of Faletto and Bien (2022). genClusteredDataWeightedRandom() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature with unequal correlations (the latent features themselves are also provided) that are determined at random. getLassoLambda() uses a data set to choose a good value of lambda for subsamples of size n/2 (as in cluster stability selection) by cross-validation. getModelSize() estimates the best size for a lasso model on a provided data set. printCssDf() converts the output of the css() function (an object of class cssr) to a data.frame that is ready to be printed. We provide end-user access to printCssDf() because this data.frame itself may be useful as an object that summarizes the output from css(). print.cssr() is the print function for objects of class cssr. genClusteredData() checkGenClusteredDataInputs() checks that the inputs to genClusteredData() are as expected. genZmuY() generates the latent Z, the weak signal and noise features in X, the latent mu, and the observed y from the specified parameters. getNoiseVar() calculates the variance of the noise to add to Z so that the proxies have the specified correlation with the latent variable Z. genClusteredDataWeighted() checkGenClusteredDataWeightedInputs() verifies the inputs to genClusteredDataWeighted(). getLassoLambda() getModelSize() printCssDf() getSelectionPrototypes() identifies the prototypes from selected clusters (the feature in each cluster that is most correlated with the response) print.cssr() genClusteredData() #' Generate randomly sampled data including noisy observations of latent #' variables #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). Data is generated in the same way as in the simulations #' from Faletto and Bien (2022). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho Integer or numeric; the correlation of the proxies in each cluster #' with the latent variable. Must be in (0, 1] (greater than 0 and at most 1). Default is 0.9. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @importFrom stats rnorm runif #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' dim(data$X) #' length(data$y) #' @export genClusteredData <- function(n, p, k_unclustered, cluster_size, n_clusters=1, sig_clusters=1, rho=0.9, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataInputs(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. First, get needed # variances of noise to add noise_var <- getNoiseVar(rho) # Generate these noise features noise_mat <- matrix(stats::rnorm(n*n_clusters*cluster_size, mean=0, sd=sqrt(noise_var)), n, n_clusters*cluster_size) # Create matrix of proxies. Each cluster's cluster_size proxies are its # latent Z column plus the matching noise columns (#58); column-expand Z to # the noise block layout in one vectorized add (replaces the per-cluster # block loop; noise_mat was already drawn above, so RNG order is unchanged). # For n_clusters == 1, genZmuY returns Z as a bare numeric vector, and # as.matrix(Z) promotes it to a one-column matrix before the column-expand. col_clust <- rep(1:n_clusters, each = cluster_size) proxy_mat <- as.matrix(Z)[, col_clust, drop = FALSE] + noise_mat return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } The three genClusteredData* validators share the bulk of their checks. To keep them from drifting apart (the source of the validation inconsistencies fixed in #13), the common checks live in three shared helpers: checkGenClusteredDataInputsPre() (the checks that precede each generator’s correlation-specific checks), checkGenClusteredDataInputsPost() (the checks that follow them), and checkGenClusteredDataInputsSnrSigma() (the checks on whichever of snr and sigma_eps_sq was supplied). The two weighted validators additionally share their rho_high / rho_low checks, in checkRhoHighLow(). Each validator calls Pre(), then its own correlation/strength checks, then Post(), then SnrSigma() – preserving each validator’s exact original check order. #' Shared leading input checks for the genClusteredData* generators #' #' The checks every genClusteredData* validator runs before its #' correlation-specific checks (sig_clusters, n_clusters, and cluster_size). #' @param sig_clusters,n_clusters,cluster_size As documented in #' `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsPre <- function(sig_clusters, n_clusters, cluster_size){ stopifnot(is.numeric(sig_clusters) | is.integer(sig_clusters)) stopifnot(sig_clusters <= n_clusters) stopifnot(sig_clusters >= 0) stopifnot(sig_clusters == round(sig_clusters)) stopifnot(is.numeric(n_clusters) | is.integer(n_clusters)) stopifnot(n_clusters == round(n_clusters)) stopifnot(n_clusters >= 1) stopifnot(is.numeric(cluster_size) | is.integer(cluster_size)) stopifnot(cluster_size == round(cluster_size)) stopifnot(cluster_size >= 2) } #' Shared trailing input checks for the genClusteredData* generators #' #' The checks every genClusteredData* validator runs after its #' correlation-specific checks: the beta coefficients, k_unclustered, the #' feature-count lower bound, and that exactly one of snr / sigma_eps_sq is #' given. (Each validator then runs its own type/range checks on whichever of #' snr / sigma_eps_sq was supplied.) #' @param p,k_unclustered,cluster_size,n_clusters,beta_latent,beta_unclustered,snr,sigma_eps_sq #' As documented in `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsPost <- function(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq){ stopifnot(beta_latent != 0) stopifnot(beta_unclustered != 0) stopifnot(is.numeric(k_unclustered) | is.integer(k_unclustered)) stopifnot(k_unclustered >= 1) stopifnot(k_unclustered == round(k_unclustered)) stopifnot(is.numeric(p) | is.integer(p)) stopifnot(p == round(p)) stopifnot(p >= n_clusters*cluster_size + k_unclustered) # Same as make_sparse_blocked_linear_model_random, but ith coefficient # of weak signal features is beta_unclustered/sqrt(i) in order to have # a definitive ranking of weak signal features. if(is.na(snr) & is.na(sigma_eps_sq)){ stop("Must specify one of snr or sigma_eps_sq") } if(!is.na(snr) & !is.na(sigma_eps_sq)){ stop("Only one of snr and sigma_eps_sq may be specified") } } #' Shared snr / sigma_eps_sq input checks for the genClusteredData* generators #' #' Validates whichever of snr / sigma_eps_sq was supplied (exactly one is non-NA #' by this point, enforced by `checkGenClusteredDataInputsPost()`): it must be #' numeric and length 1, and positive (snr) or non-negative (sigma_eps_sq). #' Previously only `genClusteredData()` ran the full type/length checks; the two #' weighted generators ran a leaner version that silently accepted a #' non-numeric snr / sigma_eps_sq (which then failed later inside `genZmuY()`). #' Sharing this helper makes the three consistent (#35). #' @param snr,sigma_eps_sq As documented in `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsSnrSigma <- function(snr, sigma_eps_sq){ if(is.na(snr)){ stopifnot(all(!is.na(sigma_eps_sq))) stopifnot(is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq)) stopifnot(length(sigma_eps_sq) == 1) stopifnot(sigma_eps_sq >= 0) } else{ stopifnot(is.numeric(snr) | is.integer(snr)) stopifnot(length(snr) == 1) stopifnot(snr > 0) } } #' Shared correlation-argument checks for the weighted genClusteredData* #' generators #' #' Validates rho_high and rho_low for #' `checkGenClusteredDataWeightedInputs()` and #' `checkGenClusteredDataWeightedRandomInputs()`: each must be a single #' non-missing number, with 0 < rho_low <= rho_high <= 1. #' #' Two things here are contract, not style. The formals must stay named #' `rho_high` / `rho_low`, because `stopifnot()` deparses the expression as #' written here, so the FORMAL's name is what the user sees (#162). And the #' type/length/NA checks must precede every range check: `"0.9" >= 0.5` is #' TRUE, since R coerces the number to a string and compares as strings #' (`"10" >= 9` is FALSE, which is the giveaway); `!is.na()` is #' vectorized, so a length-2 argument containing NA reports the plural "are #' not all TRUE" rather than the length violation; and #' `stopifnot(numeric(0) <= 1)` does not error at all, since #' `all(logical(0))` is TRUE. The tests pin every message below, so changing #' either turns many expectations red at once -- the failure mode to guard #' against is "repairing" them to match the new messages, which ships #162's #' defect green. #' @param rho_high,rho_low As documented in #' `checkGenClusteredDataWeightedInputs()` and #' `checkGenClusteredDataWeightedRandomInputs()`. Both callers are named #' because the two describe these arguments differently -- fixed correlations #' for the strong and weak proxies in one, the endpoints of the interval each #' proxy's correlation is drawn from in the other -- and their rho_high #' defaults differ (0.9 and 1). The constraint enforced here is the same for #' both. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkRhoHighLow <- function(rho_high, rho_low){ stopifnot(is.numeric(rho_high) | is.integer(rho_high)) stopifnot(length(rho_high) == 1) stopifnot(!is.na(rho_high)) stopifnot(is.numeric(rho_low) | is.integer(rho_low)) stopifnot(length(rho_low) == 1) stopifnot(!is.na(rho_low)) stopifnot(rho_high <= 1) stopifnot(rho_high > 0) stopifnot(rho_low > 0) stopifnot(rho_high >= rho_low) } checkGenClusteredDataInputs() #' Check inputs to genClusteredData #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho Integer or numeric; the correlation of the proxies in each cluster #' with the latent variable. Must be in (0, 1] (greater than 0 and at most 1). Default is 0.9. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputs <- function(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) # rho is a (0, 1] scalar, so it gets checkAlpha()'s block verbatim (#162): # the type/length/NA checks it previously lacked entirely, plus the upper # bound the help page has always documented. Type/length/NA must precede # the range checks. "0.8" > 0 is TRUE, because R compares character to # numeric as strings, so a character rho passed straight through; and # NA_real_ > 0 does error, but as "rho > 0 is not TRUE", blaming the bound # rather than the missingness. Without the length check a vector rho # recycled its noise variance ELEMENTWISE over the flat rnorm() draw in # genClusteredData(), alternating row by row inside every proxy column -- # so no proxy kept a requested correlation, not merely some of them. stopifnot(is.numeric(rho) | is.integer(rho)) stopifnot(length(rho) == 1) stopifnot(!is.na(rho)) stopifnot(rho > 0) stopifnot(rho <= 1) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } genZmuY() #' Generates Z, weak signal features in X, noise features in X, mu, and y #' from provided parameters #' #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{Z}{The #' latent features; either a numeric vector (if n_clusters == 1) or a numeric #' matrix (if n_clusters > 1). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} #' \\item{other_X}{A numeric matrix of n observations from a multivariate normal #' distribution generated using the specified parameters, containing the weak #' signal features and the noise features that will eventually be in X. (The #' only missing features are the proxies for the latent features Z.)} #' #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @keywords internal #' @noRd genZmuY <- function(n, p, k_unclustered, cluster_size, n_clusters, sig_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq){ # Reject n < 2 up front: n = 1 collapses orig_feat_mat[, cols] to a vector # (no drop=FALSE below), which fails downstream with a cryptic "incorrect # number of dimensions". n is not validated by the shared input checkers, so # guard it here -- the one point every generator funnels through (#70). stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n >= 2) # Generate Z, weak signal features, and noise features (total of # p - n_clusters*(cluster_size - 1)) features) p_orig_feat_mat <- p - n_clusters*(cluster_size - 1) stopifnot(p_orig_feat_mat >= k_unclustered + n_clusters) orig_feat_mat <- matrix(stats::rnorm(n*p_orig_feat_mat), n, p_orig_feat_mat) # First n_clusters features are Z. Next k_unclustered features are weak # signal features. Any remaining features are noise features. Z <- orig_feat_mat[, 1:n_clusters] other_X <- orig_feat_mat[, (n_clusters + 1):p_orig_feat_mat, drop = FALSE] # Ready to create mu and y if(sig_clusters == 0){ mu <- rep(0, n) # null latent model; weak-signal features add below } else if(n_clusters > 1){ if(sig_clusters > 1){ mu <- Z[, seq_len(sig_clusters)] %*% rep(beta_latent, sig_clusters) } else{ mu <- Z[, 1] * beta_latent } } else{ mu <- Z * beta_latent } for(j in 1:k_unclustered){ mu <- mu + beta_unclustered/sqrt(j)*other_X[, j] } mu <- as.numeric(mu) # If SNR is null, use sigma_eps_sq if(!is.na(sigma_eps_sq)){ sd <- sqrt(sigma_eps_sq) }else{ sd <- sqrt(sum(mu^2) / (n * snr)) # taking snr = ||mu||^2 /(n * sigma^2) } stopifnot(is.numeric(sd) | is.integer(sd)) stopifnot(length(sd) == 1) stopifnot(!is.na(sd)) stopifnot(sd >= 0) y <- as.numeric(mu + rnorm(n, mean=0, sd=sd)) return(list(Z=Z, mu=mu, y=y, other_X=other_X)) } No tests for genZmuY(). getNoiseVar(): #' Get variance of noise to add to Z in order to yield proxies X with desired #' correlations with Z #' #' @param rho A numeric vector of desired correlations for each proxy to have #' with Z. Note: correlations must be in (0, 1] (positive and at most 1). #' @return A vector of variances of independent Gaussian random variables to add #' to Z in order to yield proxies with the desired correlations with Z. #' @author Gregory Faletto, Jacob Bien #' @examples #' # Noise variance needed so a proxy Z + N(0, v) attains each target #' # correlation with Z (correlations must be in (0, 1] (positive and at most 1)). #' getNoiseVar(c(0.9, 0.5, 1)) #' @export getNoiseVar <- function(rho){ # Correlation between standard normal Z and X = Z + epsilon where epsilon # is normal, independent of Z, and has mean 0 and variance sig_eps_sq: # # E[Z X]/sqrt{Var(Z) Var(X)} # = (E[Z^2] + E[Z*epsilon])/sqrt{1*(1 + sig_eps_sq)} # = (1 + 0)/sqrt{1 + sig_eps_sq} # # So we have # rho = 1/sqrt{1 + sig_eps_sq} # \\iff 1 + sig_eps_sq = 1/rho^2 # \\iff sig_eps_sq = 1/rho^2 - 1 stopifnot(is.numeric(rho) | is.integer(rho)) stopifnot(all(!is.na(rho))) stopifnot(length(rho) >= 1) stopifnot(all(rho > 0)) stopifnot(all(rho <= 1)) return(1/rho^2 - 1) } finalizeGenClusteredData() is the shared tail of all three genClusteredData* generators: once each generator has built its cluster-proxy matrix (the only step where the three differ), this helper column-binds the proxies with the remaining features, coerces the latent features to a matrix, runs the common output dimension checks, and returns the standard list(X, y, Z, mu). #' Assemble and validate the output of a genClusteredData* generator #' #' Shared tail of `genClusteredData()`, `genClusteredDataWeighted()`, and #' `genClusteredDataWeightedRandom()`: column-bind the freshly generated cluster #' proxies with the remaining features, coerce the latent features to a matrix, #' run the common output dimension checks, and return the standard #' `list(X, y, Z, mu)`. #' @param proxy_mat Numeric matrix; the n by n_clusters*cluster_size block of #' generated cluster proxies. #' @param other_X Numeric matrix; the weak-signal and noise features (the #' non-proxy columns of X), as returned by `genZmuY()`. #' @param y Numeric vector; the response, as returned by `genZmuY()`. #' @param mu Numeric vector; the expected response, as returned by `genZmuY()`. #' @param Z The latent features, as returned by `genZmuY()` (a numeric vector #' when n_clusters == 1); coerced to a matrix here. #' @param n Integer or numeric; the number of observations. #' @param p Integer or numeric; the total number of features (columns of X). #' @param n_clusters Integer or numeric; the number of latent variables. #' @return A list with elements X (numeric matrix), y (numeric vector), Z #' (numeric matrix), and mu (numeric vector). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd finalizeGenClusteredData <- function(proxy_mat, other_X, y, mu, Z, n, p, n_clusters){ X <- cbind(proxy_mat, other_X) Z <- as.matrix(Z) # Check output stopifnot(length(mu) == n) stopifnot(nrow(X) == n) stopifnot(ncol(X) == p) if(any(!is.na(Z))){ stopifnot(nrow(Z) == n) stopifnot(ncol(Z) == n_clusters) } return(list(X=X, y=y, Z=Z, mu=mu)) } No tests for finalizeGenClusteredData(); it is exercised through the three genClusteredData* generators (including their characterization snapshots). genClusteredDataWeighted() #' Generate randomly sampled data including noisy observations of latent #' variables, where proxies differ in their relevance (noise level) #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). Data is generated in the same way as in the simulations #' from Section 5.3 of Faletto and Bien (2022). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_strong_cluster_vars Integer or numeric; among the cluster_size #' proxies in each cluster, the first n_strong_cluster_vars will have a high #' correlation (rho_high) with the latent variable and the next cluster_size - #' n_strong_cluster_vars will have a low correlation (rho_low) with the latent #' variable. Must satisfy `1 <= n_strong_cluster_vars < cluster_size` (each #' cluster must contain at least one strong proxy and at least one weak proxy). #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the correlation of the "strong proxies" #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 0.9. #' @param rho_low Integer or numeric; the correlation of the "weak proxies" in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredDataWeighted(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_strong_cluster_vars = 2, n_clusters = 1, snr = 3) #' dim(data$X) #' @export genClusteredDataWeighted <- function(n, p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters=1, sig_clusters=1, rho_high=0.9, rho_low=0.5, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataWeightedInputs(p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. noise_var_high <- getNoiseVar(rho_high) noise_var_low <- getNoiseVar(rho_low) # Create matrix of proxies Z <- as.matrix(Z) proxy_mat <- matrix(as.numeric(NA), n, n_clusters*cluster_size) for(i in 1:n_clusters){ for(j in 1:n_strong_cluster_vars){ proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_high)) } for(j in (n_strong_cluster_vars + 1):cluster_size){ proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_low)) } } return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } checkGenClusteredDataWeightedInputs() #' Check inputs to genClusteredDataWeighted #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_strong_cluster_vars Integer or numeric; among the cluster_size #' proxies in each cluster, n_strong_cluster_vars will have a high correlation #' (rho_high) with the latent variable and cluster_size - n_strong_cluster_vars #' will have a low correlation (rho_low) with the latent variable. Must satisfy #' `1 <= n_strong_cluster_vars < cluster_size` (each cluster must contain at #' least one strong proxy and at least one weak proxy). #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the correlation of the "strong proxies" #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 0.9. #' @param rho_low Integer or numeric; the correlation of the "weak proxies" in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataWeightedInputs <- function(p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) stopifnot(is.integer(n_strong_cluster_vars) | is.numeric(n_strong_cluster_vars)) stopifnot(!is.na(n_strong_cluster_vars)) stopifnot(length(n_strong_cluster_vars) == 1) stopifnot(n_strong_cluster_vars == round(n_strong_cluster_vars)) stopifnot(n_strong_cluster_vars >= 1) stopifnot(n_strong_cluster_vars < cluster_size) checkRhoHighLow(rho_high, rho_low) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } No tests for checkGenClusteredDataWeightedInputs() genClusteredDataWeightedRandom() #' Generate randomly sampled data including noisy observations of latent #' variables, where proxies differ in their relevance (noise level) #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the maximum correlation of the proxies #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 1. #' @param rho_low Integer or numeric; the minimum correlation of the proxies in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredDataWeightedRandom(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' dim(data$X) #' @export genClusteredDataWeightedRandom <- function(n, p, k_unclustered, cluster_size, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=0.5, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataWeightedRandomInputs(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. # Create matrix of proxies Z <- as.matrix(Z) proxy_mat <- matrix(as.numeric(NA), n, n_clusters*cluster_size) for(i in 1:n_clusters){ for(j in 1:cluster_size){ # Choose correlation at random rho_ij <- runif(n=1, min=rho_low, max=rho_high) # Get noise variance noise_var_ij <- getNoiseVar(rho_ij) proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_ij)) } } return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } checkGenClusteredDataWeightedRandomInputs() #' Check inputs to genClusteredDataWeightedRandom #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the maximum correlation of the proxies #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 1. #' @param rho_low Integer or numeric; the minimum correlation of the proxies in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataWeightedRandomInputs <- function(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) checkRhoHighLow(rho_high, rho_low) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } No tests for checkGenClusteredDataWeightedRandomInputs() getLassoLambda(): #' Get lambda value for lasso #' #' Chooses a lambda value for the lasso used on a subsample of size n/2 (as in #' cluster stability selection) by cross-validation. #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors that will be used by cluster stability #' selection. Must not contain missing (`NA`) values. #' @param y The response; an n-dimensional numeric or integer vector. (Unlike #' in the more general css setup, this response must be real-valued since #' lambda will be determined using the lasso with cross-validation.) #' @param lambda_choice Character; either "min" or "1se". If "min", chooses #' the lambda that minimizes the cross-validated error; if "1se", chooses the #' largest lambda within one standard error of the minimum error lambda #' (resulting in a smaller selected set, which may be desirable because the #' model size corresponding to the minimum error lambda tends to be larger #' than optimal. See, for example, Bühlmann and Meinshausen 2006, Prop. 1 and #' Bühlmann and van de Geer 2011, Section 2.5.1.). Default is "1se". #' @param nfolds Numeric or integer; the number of folds for cross-validation. #' Must be at least 3 (the minimum for cv.glmnet). Default is 10. #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Default is 1 (in which case the penalty is for lasso). #' @return A numeric; the selected value of lambda. #' @author Gregory Faletto, Jacob Bien #' @references Bühlmann, P., & Meinshausen, N. (2006). High-Dimensional Graphs #' and Variable Selection With the Lasso. \\emph{The Annals of Statistics}, #' 34(3), 1436–1462. \\url{https://doi.org/10.1214/009053606000000281}. #' \\cr Peter Bühlmann and Sara van de Geer. Statistics for High-Dimensional #' Data. \\emph{Springer Series in Statistics}. Springer, Heidelberg, 2011. ISBN #' 978-3-642-20191-2. \\url{http://dx.doi.org/10.1007/978-3-642-20192-9}. \\cr #' Jerome Friedman, Trevor Hastie, Robert Tibshirani (2010). Regularization #' Paths for Generalized Linear Models via Coordinate Descent. \\emph{Journal of #' Statistical Software}, 33(1), 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' lambda <- getLassoLambda(X = data$X, y = data$y, nfolds = 5) #' lambda #' @export getLassoLambda <- function(X, y, lambda_choice="1se", nfolds=10, alpha=1){ stopifnot(is.character(lambda_choice)) stopifnot(length(lambda_choice) == 1) stopifnot(!is.na(lambda_choice)) stopifnot(lambda_choice %in% c("min", "1se")) checkNoNAs(X, "X") # Accept a data.frame like the other X-accepting exports (#51): coerce to a # matrix via the shared helper. clusters = list() makes the column-count # guard inert (getLassoLambda has no clusters argument). X <- coerceDataFrameToMatrix(X, clusters = list()) stopifnot(is.matrix(X)) stopifnot(is.numeric(X) | is.integer(X)) # Require at least two features, mirroring css()'s stopifnot(p >= 2). A 1-col # X (e.g. cssSelect()/cssPredict() called with p = 1) would otherwise reach # cv.glmnet with a single column and fail cryptically; this fires the same # clean "p >= 2 is not TRUE" message as css(). p <- ncol(X) stopifnot(p >= 2) n <- nrow(X) stopifnot(is.numeric(nfolds) | is.integer(nfolds)) stopifnot(length(nfolds) == 1) stopifnot(nfolds == round(nfolds)) stopifnot(nfolds >= 3) checkAlpha(alpha) # Since we are using the lasso, we require y to be a real-valued response # (unlike for the general cluster stability selection procedure, where y # can have a more general format as long as a suitable feature selection # function is provided by the user). checkFiniteY also rejects NA/NaN/Inf # here, BEFORE the random subsample below, so a non-finite y fails fast and # deterministically rather than only when the bad value lands in the draw. checkFiniteY(y, "y") stopifnot(n == length(y)) # Sample size to use: inflate n/2 by a factor of nfolds/(nfolds - 1), # so that each individual lasso fit is of size floor(n/2) n_sample <- min(round(n/2*nfolds/(nfolds - 1)), n) # n_sample is the number of observations actually passed to cv.glmnet. If it # is too small for even 3-fold CV, error clearly here (reporting the # requested nfolds) instead of letting cv.glmnet crash with "nfolds must be # bigger than 3". Otherwise clamp nfolds into [3, n_sample] so we never end # up below glmnet's minimum or above the available sample size. if(n_sample < 3){ stop(paste0("Sample size n = ", n, " is too small to choose lambda by ", nfolds, "-fold cross-validation; supply a larger n, a smaller nfolds, or lambda directly.")) } nfolds <- max(3L, min(nfolds, n_sample)) inds_size <- sample(1:n, n_sample) # cv.glmnet overrides grouped to FALSE, and warns that it did, whenever a # fold would hold fewer than 3 observations -- its rule is nrow(x)/nfolds < 3. # Setting grouped here to what cv.glmnet would set anyway leaves the fit # identical and spares small-n callers a warning about their sample size that # says nothing about cssr (#186). x has n_sample rows, and nfolds is the # clamped value just above. That rule is specific to the gaussian family # fixed just below -- cv.coxnet flips grouped the other way -- so a family # change would invalidate this guard. getModelSize() carries the same guard; # a change to either belongs in both. size_results <- glmnet::cv.glmnet(x=X[inds_size, ], y=y[inds_size], family="gaussian", nfolds=nfolds, alpha=alpha, grouped=n_sample/nfolds >= 3) lambda_ret <- size_results[[paste("lambda.", lambda_choice, sep="")]] # Check output stopifnot(length(lambda_ret) == 1) stopifnot(is.numeric(lambda_ret) | is.integer(lambda_ret)) stopifnot(lambda_ret >= 0) return(lambda_ret) } getModelSize(): #' Automated estimation of model size #' #' This function is uses the lasso with cross-validation to estimate the #' model size. Before using the lasso, in each cluster all features will be #' dropped from X except the one feature with the highest marginal correlation #' with y, as in the protolasso (Reid and Tibshirani 2016). #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y A length-n numeric vector containing the responses; `y[i]` is the #' response corresponding to observation `X[i, ]`. (Note that for the css #' function, y does not have to be a numeric response, but for this function, #' the underlying selection procedure is the lasso, so y must be a real-valued #' response.) #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of css. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). Any identical (duplicated) clusters will be removed, #' keeping the first occurrence and its name. CAUTION: if the provided X is a #' data.frame that #' contains a categorical feature with more than two levels, then the resulting #' matrix made from model.matrix will have a different number of columns than #' the provided data.frame, some of the feature numbers will change, and the #' clusters argument will not work properly (in the current version of the #' package). To get correct results in this case, please use model.matrix to #' convert the data.frame to a numeric matrix on your own, then provide this #' matrix and cluster assignments with respect to this matrix. #' @param alpha Numeric; the elastic net mixing parameter for the #' cross-validated fit used to estimate the model size. Must be in `(0, 1]`. #' Default is 1 (in which case the penalty is the lasso). Set alpha to match #' the alpha used for feature selection so the model-size estimate is #' consistent with the elastic-net selection (see `cssSelect` / `cssPredict`). #' @return An integer; the estimated size of the model. The minimum returned #' value is 1, even if the lasso with cross-validation chose no features. #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' getModelSize(X = data$X, y = data$y, clusters = clusters) #' @export getModelSize <- function(X, y, clusters, alpha = 1){ # Validate alpha (a single number in (0, 1]). alpha is threaded into the # cv.glmnet fit below so the model-size estimate uses the same elastic-net # mixing as feature selection. checkAlpha(alpha) stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) stopifnot(is.numeric(X) | is.integer(X)) n <- nrow(X) # Since the model size will be determined by cross-validation, the provided # y must be real-valued and finite (this should be checked internally in # other functions before getModelSize is called, but this check is here just # in case). checkFiniteY(y, "y") stopifnot(length(y) == n) # Check clusters argument clusters <- checkCssClustersInput(clusters) ### Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } clusters <- formatClusters(clusters, p=ncol(X), clust_names=clust_names)$clusters X_size <- X if(length(clusters) > 0){ # Create modified design matrix by dropping all but one feature from # each cluster feats_to_drop <- integer() for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] if(length(cluster_i) > 1){ feat_to_keep <- identifyPrototype(cluster_i, X, y) feats_to_drop <- c(feats_to_drop, setdiff(cluster_i, feat_to_keep)) } } if(length(feats_to_drop) > 0){ X_size <- X_size[, -1*feats_to_drop, drop=FALSE] } } # cv.glmnet requires at least two columns; if cluster reduction leaves a # single feature, the only possible model size is 1. if(ncol(X_size) < 2){ return(1L) } # 10 is cv.glmnet's own default for nfolds; naming it keeps the fit and the # grouped guard below from ever disagreeing about the fold count. nfolds_size <- 10L # As in getLassoLambda(): cv.glmnet overrides grouped to FALSE, and warns, # when nrow(x)/nfolds < 3, for the gaussian family fixed just below (other # families differ; cv.coxnet flips grouped the other way). Setting it # explicitly is behavior-identical and keeps that nag out of small-n callers' # consoles (#186). nrow(X_size), not the already-bound n, because it is # glmnet's N = nrow(x) for the very matrix passed as x -- the two are equal # here only because cluster reduction drops columns and never rows. size_results <- glmnet::cv.glmnet(x=X_size, y=y, family="gaussian", alpha=alpha, nfolds=nfolds_size, grouped=nrow(X_size)/nfolds_size >= 3) coefs <- as.numeric(glmnet::coef.glmnet(size_results, s="lambda.1se")) # Number of nonzero coefficients (subtract one in order to ignore intercept) size <- length(coefs[coefs != 0]) - 1 # Check output stopifnot(is.numeric(size) | is.integer(size)) stopifnot(!is.na(size)) stopifnot(length(size) == 1) stopifnot(size == round(size)) return(as.integer(max(size, 1))) } buildCssDf() builds the printable cluster-summary data.frame from a css_results object and an already-obtained named vector of selected clusters. It is factored out of printCssDf() (issue #129) so that a caller which has already computed the selected clusters – notably summary.cssr(), which calls getCssSelections() itself – can reuse that result instead of triggering a second identical getCssSelections() call. It is an internal (@noRd) helper, so the exported printCssDf() keeps its exact signature and man page: #' Build the printable cluster-summary data.frame from selected clusters #' #' Constructs the data.frame returned by printCssDf() (and summary.cssr()) from #' a css_results object and an already-obtained named vector of selected #' clusters. Factored out of printCssDf() (#129) so callers that have already #' computed the selected clusters (e.g. summary.cssr(), which calls #' getCssSelections() itself) can reuse that result rather than triggering a #' second identical getCssSelections() call. Because cluster selection is #' invariant to the weighting rule, the sel_clusts computed by summary.cssr() #' for any weighting matches the "sparse"-default selection printCssDf() would #' recompute, so the returned data.frame is byte-identical either way. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param sel_clusts A named numeric vector of selected clusters with their #' selection proportions, as returned in the selected_clusts element of #' getCssSelections() / getSelectedClusters() (the value printCssDf() itself #' obtains via getCssSelections()). May be empty (length 0), in which case a #' well-formed zero-row data.frame is returned. #' @return A data.frame; each row contains a cluster, arranged in decreasing #' order of cluster selection proportion from top to bottom (see printCssDf() #' for the full column description). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd buildCssDf <- function(css_results, sel_clusts){ # An empty selection is valid post-#107 (e.g. cutoff = 1 with # min_num_clusts = 0 when no cluster clears the cutoff). Return a well-formed # zero-row data.frame whose columns mirror the populated branch below for the # same object: 5 columns (with ClustProtoName) when X has column names, 4 # otherwise -- names(prototypes) is non-NULL iff colnames(css_results$X) is, # since prototype names come from colnames(X). (#120) if(length(sel_clusts) == 0){ if(!is.null(colnames(css_results$X))){ return(data.frame(ClustName=character(0), ClustProtoName=character(0), ClustProtoNum=integer(0), ClustSelProp=numeric(0), ClustSize=integer(0))) } return(data.frame(ClustName=character(0), ClustProtoNum=integer(0), ClustSelProp=numeric(0), ClustSize=integer(0))) } # Get prototypes (feature from each cluster with highest selection # proportion, breaking ties by using marginal correlations of features with # y from data provided to css if y is real-valued) prototypes <- getSelectionPrototypes(css_results, sel_clusts) # Cluster selection proportions if(length(sel_clusts) > 1){ sel_clust_sel_props <- colMeans(css_results$clus_sel_mat[, names(sel_clusts)]) } else{ sel_clust_sel_props <- mean(css_results$clus_sel_mat[, names(sel_clusts)]) } # Data.frame: name of cluster, cluster prototype, selection proportion, # cluster size if(!is.null(names(prototypes))){ print_df <- data.frame(ClustName=names(sel_clusts), ClustProtoName=names(prototypes), ClustProtoNum=unname(prototypes), ClustSelProp=sel_clust_sel_props, ClustSize=lengths(sel_clusts)) } else{ print_df <- data.frame(ClustName=names(sel_clusts), ClustProtoNum=unname(prototypes), ClustSelProp=sel_clust_sel_props, ClustSize=lengths(sel_clusts)) } print_df <- print_df[order(print_df$ClustSelProp, decreasing=TRUE), ] rownames(print_df) <- NULL stopifnot(is.data.frame(print_df)) stopifnot(nrow(print_df) >= 1) return(print_df) } printCssDf(): #' Prepares a data.frame summarizing cluster stability selection output to print #' #' Print a summary of the information from the css function. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param cutoff Numeric; the outputted data.frame will display only those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are displayed, or #' max_num_clusts are, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A data.frame; each row contains a cluster, arranged in decreasing #' order of cluster selection proportion from top to bottom. The columns are #' ClustName (the name of the cluster that was either provided to css or made by #' css if no name was provided); ClustProtoName (the name of the selection #' prototype from the cluster, which is the feature with the greatest individual #' selection proportion among all the cluster members, with ties broken by #' choosing the feature with the highest correlation with the response if the #' response is real-valued; only returned if the features are named), #' ClustProtoNum (the column number of the prototype in the X matrix provided to #' css), ClustSelProp (the cluster's selection proportion), and ClustSize (the #' size of the cluster). #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' printCssDf(res) #' @export printCssDf <- function(css_results, cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) checkCutoff(cutoff) p <- ncol(css_results$feat_sel_mat) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) sel_clusts <- getCssSelections(css_results, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts)$selected_clusts # printCssDf keeps its exact exported signature; the table-building work # (empty-selection handling, prototypes, selection proportions, ordering) # now lives in the internal buildCssDf() helper so summary.cssr() can reuse # an already-computed sel_clusts instead of making a second identical # getCssSelections() call. Byte-identical: buildCssDf() consumes sel_clusts # exactly as this body did. (#129) return(buildCssDf(css_results, sel_clusts)) } getSelectionPrototypes() #' Identify selection prototypes from selected clusters #' #' Takes in list of selected clusters and returns an integer vector of the #' indices of the features that were most frequently selected from each cluster #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param selected_clusts A list of integer vectors; each vector must contain #' the indices of features in a cluster. #' @return An integer vector (of length equal to the number of clusters) of the #' indices of the feature prototypes (the features from each cluster that were #' selected the most often individually by the base method in cluster stability #' selection). In the case of a tie, the tie is broken by choosing the feature #' most correlated with the response in the full data set provided to css. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectionPrototypes <- function(css_results, selected_clusts){ # Check inputs stopifnot(inherits(css_results, "cssr")) stopifnot(is.list(selected_clusts)) n_selected_clusts <- length(selected_clusts) # An empty selection is valid post-#107: getCssSelections() can return zero # selected clusters (e.g. cutoff = 1 with min_num_clusts = 0 when no cluster # clears the cutoff). Return an empty integer vector before the non-empty # guards below; this also avoids the 1:0 foot-gun in the for loop. (#120) if(n_selected_clusts == 0){ return(integer(0)) } stopifnot(n_selected_clusts >= 1) stopifnot(all(lengths(selected_clusts) >= 1)) prototypes <- rep(as.integer(NA), n_selected_clusts) feat_sel_props <- colMeans(css_results$feat_sel_mat) for(i in 1:n_selected_clusts){ clust_i <- selected_clusts[[i]] sel_props_i <- feat_sel_props[clust_i] proto_i <- clust_i[sel_props_i == max(sel_props_i)] stopifnot(length(proto_i) >= 1) if(length(proto_i) > 1){ if(is.numeric(css_results$y) | is.integer(css_results$y)){ # Break tie by marginal correlation. suppressWarnings + NA->0 # mirrors identifyPrototype (#59): a constant column has # undefined correlation (cor() returns NA with a # "standard deviation is zero" warning) -- treat it as 0 so # it never wins the tie-break and never poisons max() (#68). corrs_i <- suppressWarnings(abs(stats::cor( css_results$X[, proto_i, drop = FALSE], css_results$y)[, 1])) corrs_i[is.na(corrs_i)] <- 0 proto_i <- proto_i[corrs_i == max(corrs_i)] } } # If there is still a tie, break by choosing the first feature of those # remaining prototypes[i] <- proto_i[1] names(prototypes)[i] <- colnames(css_results$X)[proto_i[1]] } # Check output stopifnot(is.integer(prototypes)) stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) return(prototypes) } print.cssr() #' Print cluster stability selection output #' #' Print a summary of the information from the css function (using output from #' printCssDf function). #' @param x An object of class "cssr" (the output of the function css). #' @param cutoff Numeric; print.cssr will display only those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are displayed, or #' max_num_clusts are, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param ... Additional arguments to generic print.data.frame function #' @return Invisibly, the unchanged `cssr` object `x` (following the standard #' convention for `print` methods). Called for its side effect: printing a #' summary table with one row per cluster, arranged in decreasing order of #' cluster selection proportion from top to bottom. The printed columns are #' ClustName (the name of the cluster that was either provided to css or made by #' css if no name was provided); ClustProtoName (the name of the selection #' prototype from the cluster, which is the feature with the greatest individual #' selection proportion among all the cluster members, with ties broken by #' choosing the feature with the highest correlation with the response if the #' response is real-valued; only shown if the features are named); ClustProtoNum #' (the column number of the prototype in the X matrix provided to css); #' ClustSelProp (the cluster's selection proportion); and ClustSize (the size of #' the cluster). #' @author Gregory Faletto, Jacob Bien #' @export print.cssr <- function(x, cutoff=0, min_num_clusts=1, max_num_clusts=NA, ...){ df <- printCssDf(css_results=x, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) if(nrow(df) == 0){ # Empty selection (#120): no table to print. cat(sprintf("(no clusters selected at cutoff %s)\\n", format(cutoff))) } else{ print.data.frame(df, ...) } invisible(x) } plot.cssr() gives a base-graphics bar plot of the cluster (or feature) selection proportions, sorted in decreasing order, with the cutoff drawn as a dashed reference line (for type = \"clusters\") and the selected clusters (or features) highlighted: #' Plot cluster (or feature) selection proportions from cluster stability #' selection #' #' Produce a base-graphics bar plot of the selection proportions of a fitted #' `cssr` object: one bar per cluster (the default) or per feature, sorted in #' decreasing order of selection proportion. When `cutoff > 0` a dashed #' reference line is drawn at the cutoff (for `type = "clusters"`), and the bars #' whose cluster (or feature) is selected -- at the given `cutoff` and #' cluster-count constraints -- are highlighted in `sel_col`, the rest in #' `unsel_col`. #' #' The selection that determines the highlight is obtained from #' [getCssSelections()] with the same `cutoff`, `min_num_clusts`, #' `max_num_clusts`, and `weighting`. Which clusters are selected does not #' depend on `weighting`; which features are selected does (the weighting #' determines which members of the selected clusters have nonzero weight and are #' therefore highlighted when `type = "features"`). #' #' Note that, to match the positional argument order of [print.cssr()], the #' second positional argument is `cutoff`; `type`, `weighting`, and the #' graphical parameters must be supplied by name (for example #' `plot(x, type = "features")`). #' #' @param x An object of class "cssr" (the output of the function [css()]). #' @param cutoff Numeric; the selection-proportion threshold used both to draw #' the dashed reference line (when greater than 0) and to determine which bars #' are highlighted as selected. The dashed reference line is drawn only for #' `type = "clusters"`; for `type = "features"` no line is drawn, because the #' bars show feature proportions while highlighting follows the cluster-level #' selection. Must be between 0 and 1. Default is 0 (in which case no reference #' line is drawn and, unless `max_num_clusts` restricts it, every cluster is #' treated as selected). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' treat as selected regardless of cutoff. (If the chosen cutoff would select #' fewer than min_num_clusts clusters, the cutoff is effectively lowered until #' at least min_num_clusts clusters are selected.) Default is 1. May be set to 0 #' to allow a pure cutoff-based highlight that can be empty (no bar highlighted) #' when no cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' treat as selected regardless of cutoff. (If the chosen cutoff would select #' more than max_num_clusts clusters, the cutoff is effectively raised until at #' most max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts bars #' (or fewer than min_num_clusts) to be highlighted; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param type Character; either "clusters" (the default) to plot one bar per #' cluster, or "features" to plot one bar per feature. May be abbreviated. #' @param weighting Character; passed to [getCssSelections()] to determine which #' individual features are selected (and therefore highlighted) when #' `type = "features"`. It has no effect on the cluster bars or on which #' clusters are highlighted. Must be one of "sparse", "weighted_avg", or #' "simple_avg". Default is "sparse" (matching [getCssSelections()] and #' [selected()]). #' @param ylim Numeric vector of length 2; the y-axis limits for the bar plot. #' Default is `c(0, 1)`, the natural range of a selection proportion. #' @param sel_col The color used to fill the bars of selected clusters (or #' features). Default is "steelblue". #' @param unsel_col The color used to fill the bars of unselected clusters (or #' features). Default is "grey70". #' @param ... Additional graphical parameters passed on to #' [graphics::barplot()] (for example `main` or `cex.names`). The bar heights, #' fill colors, and `ylim` are controlled by this method; supplying `col` here, #' or the `ylim` argument, overrides the highlight colors or the default y-axis #' limits. #' @return Invisibly, the numeric vector of selection proportions that were #' plotted: the `colMeans()` of the cluster (or feature) selection matrix, #' sorted in decreasing order, named by cluster (always) or by feature (when the #' features of `X` were named; unnamed otherwise). Called primarily for its side #' effect: drawing the bar plot. #' @author Gregory Faletto, Jacob Bien #' @seealso [print.cssr()] and [summary.cssr()] for printed / tabular overviews #' of the same selection proportions; [selected()] to extract the selected #' clusters or features; [getCssSelections()] for the underlying selection used #' to highlight the bars. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' # Name the features so the feature plot shows labeled, highlighted bars #' # (genClusteredData returns X with no column names). #' X <- data$X #' colnames(X) <- paste0("V", seq_len(ncol(X))) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = X, y = data$y, lambda = 0.01, clusters = clusters, B = 10) #' # Cluster selection proportions (the default): #' plot(res) #' # Feature selection proportions, highlighting the selected features: #' plot(res, type = "features") #' @export plot.cssr <- function(x, cutoff = 0, min_num_clusts = 1, max_num_clusts = NA, type = c("clusters", "features"), weighting = "sparse", ylim = c(0, 1), sel_col = "steelblue", unsel_col = "grey70", ...){ type <- match.arg(type) sel <- getCssSelections(x, weighting = weighting, cutoff = cutoff, min_num_clusts = min_num_clusts, max_num_clusts = max_num_clusts) if(type == "clusters"){ props <- colMeans(x$clus_sel_mat) # named by cluster (guaranteed) is_sel <- names(props) %in% names(sel$selected_clusts) ylab <- "Cluster selection proportion" } else { props <- colMeans(x$feat_sel_mat) # named iff X was named is_sel <- seq_along(props) %in% as.integer(sel$selected_feats) # INDEX-based -> robust to unnamed X ylab <- "Feature selection proportion" } ord <- order(props, decreasing = TRUE) props <- props[ord]; is_sel <- is_sel[ord] labels <- names(props); if(is.null(labels)) labels <- as.character(ord) # index labels if X unnamed # Method defaults go on the DEFAULTS side of the merge so a user-supplied col # or ylim in `...` wins (matching the @param ... doc); height is forced AFTER # the merge because the bar heights ARE the selection proportions (#160a). args <- utils::modifyList( list(names.arg = labels, las = 2, ylab = ylab, col = ifelse(is_sel, sel_col, unsel_col), ylim = ylim), list(...)) args$height <- props do.call(graphics::barplot, args) if(cutoff > 0 && type == "clusters") graphics::abline(h = cutoff, lty = 2, col = "red") invisible(props) # sorted; names as-is (so it equals sort(colMeans(...)) for the test) } 5.1 Ergonomic S3 accessors: selected() and summary.cssr() The functions above (getCssSelections(), printCssDf(), print.cssr()) already expose everything an end user needs, but they take the cssr object as css_results and return heterogeneous output. For a more idiomatic R experience – mirroring the selected() and summary.stabsel() interface of the stabs package – we add a small S3 layer on top of these internals. selected() is a generic accessor that returns the selected clusters (or features) from a fitted cssr object, and summary.cssr() returns a compact, computable overview object with its own print method. Both are thin wrappers over getCssSelections()/printCssDf(); they introduce no new methodology. selected() generic: #' Extract the selected clusters or features from cluster stability selection #' #' A convenient S3 accessor for the selected clusters (the default) or the #' selected features of a fitted `cssr` object, without re-running the #' (computationally expensive) subsampling. This is a thin wrapper around #' [getCssSelections()]. #' #' Note that, unlike the `selected()` accessor in the \\pkg{stabs} package (which #' returns the selected *variables*), the default here returns the selected #' *clusters* -- the natural unit of cluster stability selection. Pass #' `type = "features"` to obtain the flat integer vector of selected features #' instead. #' #' @param object An object of class "cssr" (the output of the function [css()]). #' @param ... Additional arguments passed to methods (currently unused). #' @return For the `cssr` method: if `type = "clusters"` (the default), a named #' list of integer vectors (each the indices of the features in one selected #' cluster; an empty list if no cluster is selected); if `type = "features"`, a #' named integer vector of the indices of the selected features (an empty integer #' vector if none). #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @seealso [summary.cssr()] for an overview (counts plus a per-cluster table); #' [getCssSelections()] for the underlying selection (clusters, features, and #' weights together); [printCssDf()] and [print.cssr()] for the printed summary. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' # Selected clusters (the default): #' selected(res) #' # Selected features (a flat integer vector): #' selected(res, type = "features") #' @export selected <- function(object, ...){ UseMethod("selected") } selected.cssr() method: #' @param type Character; either "clusters" (the default) to return the named #' list of selected clusters, or "features" to return the flat integer vector of #' selected features. May be abbreviated. #' @param cutoff Numeric; only those clusters with selection proportions equal to #' at least cutoff will be selected. Must be between 0 and 1. Default is 0 (in #' which case either all clusters are selected, or max_num_clusts are selected, #' if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow #' a pure cutoff-based (threshold) selection that returns an empty result when no #' cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param weighting Character; passed to [getCssSelections()] to determine the #' weights of individual features within the selected clusters. This affects #' ONLY `type = "features"` (it determines which cluster members have nonzero #' weight and are therefore returned); it is a no-op for `type = "clusters"`, #' whose selected clusters, selection proportions, and sizes do not depend on the #' weighting. Must be one of "sparse", "weighted_avg", or "simple_avg". See #' [getCssSelections()] for details. Default is "sparse". #' @rdname selected #' @export selected.cssr <- function(object, type=c("clusters", "features"), cutoff=0, min_num_clusts=1, max_num_clusts=NA, weighting="sparse", ...){ stopifnot(inherits(object, "cssr")) type <- match.arg(type) # Thin wrapper: getCssSelections validates all inputs (checkCutoff, # checkWeighting, checkMinNumClusts, checkMaxNumClusts) and cleanly returns # empty results on an empty selection (e.g. cutoff = 1, min_num_clusts = 0). sel <- getCssSelections(object, weighting=weighting, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) if(type == "clusters"){ return(sel$selected_clusts) } return(sel$selected_feats) } summary.cssr(): #' Summarize cluster stability selection output #' #' Produce a concise, computable overview of a fitted `cssr` object: a header #' with the number of selected clusters and features (at the given cutoff), a #' per-cluster table built on top of [printCssDf()], and a placeholder for #' per-family error rate (PFER) error-control content. #' #' The returned object has class "summary.cssr" and an accompanying print method #' ([print.summary.cssr()]). Its `table` element is exactly the data.frame #' returned by [printCssDf()]: one row per selected cluster, sorted by selection #' proportion, with columns ClustName, ClustProtoName (only if the features are #' named), ClustProtoNum, ClustSelProp (the cluster's selection proportion) and #' ClustSize. #' #' If the selection is empty (for example `cutoff = 1` with `min_num_clusts = 0` #' when no cluster reaches the cutoff), `summary.cssr` returns a well-formed #' zero-row object without error: `table` is NULL and the header reports #' "0 clusters / 0 features selected". In this case [printCssDf()] and its helper #' are deliberately NOT called, as they require at least one selected cluster. #' #' The `pfer` element is a documented placeholder (NA) reserved for error-control #' content to be filled in by a future release (issue #87). #' #' @param object An object of class "cssr" (the output of the function [css()]). #' @param cutoff Numeric; only those clusters with selection proportions equal to #' at least cutoff are summarized. Must be between 0 and 1. Default is 0 (in #' which case either all clusters are summarized, or max_num_clusts are, if #' max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. Default is 1. May be set to 0 to allow a pure #' cutoff-based (threshold) selection that can be empty. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. Default is NA (in which case max_num_clusts is #' ignored). Because clusters can have tied selection proportions, ties at the #' threshold can cause more than max_num_clusts (or fewer than min_num_clusts) #' clusters to be returned; when the two constraints conflict, max_num_clusts #' takes precedence. #' @param weighting Character; passed to [getCssSelections()] to determine the #' selected features and hence the selected-feature count in the header. As in #' [selected()], it does NOT affect which clusters are selected or the #' per-cluster table. Must be one of "sparse", "weighted_avg", or "simple_avg". #' Default is "sparse". #' @param ... Additional arguments (currently unused). #' @return An object of class "summary.cssr": a named list with elements #' \\item{n_selected_clusts}{Integer; the number of selected clusters.} #' \\item{n_selected_feats}{Integer; the number of selected features.} #' \\item{cutoff}{Numeric; the cutoff that was used.} #' \\item{table}{A data.frame with one row per selected cluster (the output of #' [printCssDf()]), or NULL when the selection is empty.} #' \\item{pfer}{A placeholder (NA) for per-family error rate error-control #' content, to be filled in by a future release (issue #87).} #' @author Gregory Faletto, Jacob Bien #' @seealso [selected()] to extract just the selected clusters or features; #' [getCssSelections()] for the underlying selection; [printCssDf()] for the #' per-cluster data.frame; [print.cssr()] for the analogous printed summary. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' summary(res) #' @export summary.cssr <- function(object, cutoff=0, min_num_clusts=1, max_num_clusts=NA, weighting="sparse", ...){ stopifnot(inherits(object, "cssr")) # Selected clusters + features. getCssSelections validates all inputs # (checkCutoff / checkWeighting / checkMinNumClusts / checkMaxNumClusts) and # is empty-safe (a clean empty result when e.g. cutoff = 1 and # min_num_clusts = 0). sel <- getCssSelections(object, weighting=weighting, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) n_selected_clusts <- length(sel$selected_clusts) n_selected_feats <- length(sel$selected_feats) # Empty-selection path: do NOT call printCssDf() / getSelectionPrototypes() # here. Both assert at least one selected cluster (printCssDf: nrow >= 1; # getSelectionPrototypes: n_selected_clusts >= 1) and so would die opaquely # on an empty selection (#107). Return a well-formed zero-row summary. if(n_selected_clusts >= 1){ # Reuse the sel$selected_clusts already computed above instead of a # second identical getCssSelections() inside printCssDf(). Cluster # selection is weighting-invariant, so sel$selected_clusts (for this # weighting) matches the "sparse"-default selection printCssDf() would # recompute -- the resulting table is byte-identical. (#129) clust_table <- buildCssDf(object, sel$selected_clusts) } else{ clust_table <- NULL } out <- list(n_selected_clusts=n_selected_clusts, n_selected_feats=n_selected_feats, cutoff=cutoff, table=clust_table, pfer=NA_real_) class(out) <- "summary.cssr" return(out) } print.summary.cssr() (mirrors the print.cssr() S3-method pattern – roxygen with @export, no @examples): #' @param x An object of class "summary.cssr" (the output of [summary.cssr()]). #' @rdname summary.cssr #' @export print.summary.cssr <- function(x, ...){ cat("Cluster stability selection summary\\n") cat(sprintf("%d cluster%s / %d feature%s selected at cutoff %s\\n", x$n_selected_clusts, if(x$n_selected_clusts == 1) "" else "s", x$n_selected_feats, if(x$n_selected_feats == 1) "" else "s", format(x$cutoff))) if(is.null(x$table)){ cat("(no clusters selected at this cutoff)\\n") } else{ cat("\\n") print.data.frame(x$table, ...) } # PFER placeholder: error-control content to be filled in by issue #87. cat(sprintf("\\nPFER: %s (not yet implemented; see issue #87)\\n", format(x$pfer))) invisible(x) } "],["wrapper-functions.html", "6 Convenient wrapper functions", " 6 Convenient wrapper functions Finally, we provide convenient wrapper functions which yield user-desired output in a single step at the price of flexibility and efficiency. cssSelect() yields a selected set of clusters and features (the same output as getCssSelections()) in a single function call. cssPredict() takes in a training/selection data set as well as a test X. It uses the labeled data to select a set of features and train an OLS model on the selected features, and then it generates predictions on the test set using the fitted model. Besides requiring only a single function call to yield desired output, these wrapper functions also automatically select hyperparameters (lambda used for the lasso, a desired model size, and even selection and training splits for cssPredict()) in a sensible way if these values are not provided by the user. So these functions are very convenient for an end user who wants quick results without getting “under the hood.” The two main disadvantages of these functions are flexibility and computational efficiency. For simplicity of use, these functions do not provide as many options as the component functions they call (for example, min_num_clusts is not an available argument for these models). Further, both of these functions make (computationally intensive) calls to css() internally every time they are called, so these functions are not recommended for users who want to tinker with the model size and other parameters. Instead, it would be more efficient to call css once and then work with the output as desired using the other package functions, which are very efficient given the stored output from css(). cssSelect() and cssPredict() have no new dependencies; they rely only on already-defined functions. cssSelect(): #' Obtain a selected set of clusters and features using cluster stability #' selection #' #' Takes in data X and y and returns a set of clusters (and a set of features) #' that are useful for predicting y from the data in X. This is a wrapper #' function for css and getCssSelections. Using cssSelect is simpler, but it #' has fewer options, and it executes the full (computationally expensive) #' subsampling procedure every time it is called. In contrast, css can be #' called just once, and then getCssSelections can quickly return results using #' different values of cutoff, max_num_clusts, etc. from the calculations done #' in one call to css. #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y A length-n numeric vector containing the responses; `y[i]` is the #' response corresponding to observation `X[i, ]`. (Note that for the css #' function, y does not have to be a numeric response, but for this function, #' the underlying selection procedure is the lasso, so y must be a real-valued #' response.) #' @param clusters Optional; either an integer vector of a list of integer #' vectors; each vector should contain the indices of a cluster of features (a #' subset of 1:p). (If there is only one cluster, clusters can either be a list #' of length 1 or an integer vector.) All of the provided clusters must be #' non-overlapping. Any identical (duplicated) clusters will be removed, keeping #' the first occurrence and its name. Every feature not appearing in any cluster #' will be assumed #' to be unclustered (that is, they will be treated as if they are in a #' "cluster" containing only themselves). If clusters is a list of length 0 (or #' a list only containing clusters of length 1), then css() returns the same #' results as stability selection (so feat_sel_mat will be identical to #' clus_sel_mat). Names for the clusters will be needed later; any clusters that #' are not given names in the list clusters will be given names automatically by #' css. CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). To #' get correct results in this case, please use model.matrix to convert the #' data.frame to a numeric matrix on your own, then provide this matrix and #' cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified, and every feature is assumed to be in a "cluster" #' containing only itself). #' @param lambda Optional; the tuning parameter to be used by the lasso for #' feature selection in each subsample. If lambda is not provided, cssSelect #' will choose one automatically by cross-validation. Default is NA. #' @param cutoff Numeric; cssSelect will only select those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is NA (in which case max_num_clusts are used). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' either cutoff is used to choose the number of clusters, or if cutoff was also #' unspecified, cssSelect chooses max_num_clusts by cross-validation). Because #' clusters can have tied selection proportions, ties at the threshold can cause #' more than max_num_clusts (or fewer than min_num_clusts) clusters to be #' returned; when the two constraints conflict, max_num_clusts takes precedence. #' @param auto_select_size Logical; if TRUE, then max_num_clusts will be #' automatically estimated using the lasso with cross-validation. Default is #' TRUE, though this argument is ignored if either cutoff or max_num_clusts is #' provided. (If desired output is to return all clusters, you should set #' auto_select_size to FALSE and do not provide cutoff or max_num_clusts.) #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Drives both the choice of lambda (when lambda is not provided) and the #' elastic net fit used for feature selection in each subsample. Default is 1 #' (in which case the penalty is the lasso). #' @return A named list with three items. \\item{selected_clusts}{A named list of #' integer vectors; each vector contains the indices of the features in one of #' the selected clusters.} \\item{selected_feats}{A named integer vector; the #' indices of the features with nonzero weights from all of the selected #' clusters.} \\item{weights}{A named list of the same length as selected_clusts. #' Each list element `weights[[j]]` is a numeric vector of the weights to use for #' the jth selected cluster, and it has the same name as the cluster it #' corresponds to.} #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' data <- genClusteredData(n = 80, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- cssSelect(X = data$X, y = data$y, clusters = clusters) #' res$selected_feats #' @export cssSelect <- function(X, y, clusters = list(), lambda=NA, cutoff=NA, max_num_clusts=NA, auto_select_size=TRUE, alpha=1){ # Check inputs (most inputs will be checked by called functions) stopifnot(!is.na(auto_select_size)) stopifnot(length(auto_select_size) == 1) stopifnot(is.logical(auto_select_size)) # Validate alpha up front. This must happen before the NA-lambda branch # below (a user-supplied non-NA lambda skips getLassoLambda and therefore # its own alpha check) and before the bundling step, so that an invalid or # NA alpha is caught here with a clear message rather than deep inside the # subsampling loop. checkAlpha(alpha) stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters, convert_phrase = "the data.frame X") stopifnot(is.matrix(X)) if(!is.numeric(y) & !is.integer(y)){ stop("The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)") } # Reject a non-finite y here (after the domain message above, so that # message is preserved) so the default lambda=NA -> getLassoLambda path # fails fast rather than per-subsample later. checkFiniteY(y, "y") stopifnot(length(lambda) == 1) if(is.na(lambda)){ lambda <- getLassoLambda(X, y, alpha=alpha) } # Bundle alpha into lambda for the elastic-net fit. When alpha == 1 (the # default), leave lambda as a scalar so the pure-lasso path is byte-identical # to the original behavior. if(alpha != 1){ lambda <- c(lambda=lambda, alpha=alpha) } css_results <- css(X, y, lambda, clusters) # If no indication of how to select model size was provided, choose model # size by cross-validation if(is.na(cutoff) & is.na(max_num_clusts)){ if(auto_select_size){ max_num_clusts <- getModelSize(X, y, css_results$clusters, alpha=alpha) } } if(is.na(cutoff)){ cutoff <- 0 } # Get selected features getCssSelections(css_results, weighting="sparse", cutoff=cutoff, min_num_clusts=1, max_num_clusts=max_num_clusts) } cssPredict(): #' Wrapper function to generate predictions from cluster stability selected #' model in one step #' #' Select clusters using cluster stability selection, form cluster #' representatives, fit a linear model, and generate predictions from a matrix #' of unlabeled data. This is a wrapper function for css and getCssPreds. Using #' cssPredict is simpler, but it has fewer options, and it executes the full #' (computationally expensive) subsampling procedure every time it is called. #' In contrast, css can be called just once, and then cssPredict can quickly #' return results for different matrices of new data or using different values #' of cutoff, max_num_clusts, etc. by using the calculations done in one call to #' css. #' #' @param X_train_selec An n x p numeric matrix (preferably) or a data.frame #' (which will be coerced internally to a matrix by the function model.matrix) #' containing the p >= 2 features/predictors. The data from X_train_selec and #' y_train_selec will be split into two parts; half of the data will be used for #' feature selection by cluster stability selection, and half will be used for #' estimating a linear model on the selected cluster representatives. Must not #' contain missing (`NA`) values. #' @param y_train_selec A length-n numeric vector containing the responses; #' `y[i]` is the response corresponding to observation `X[i, ]`. Unlike the more #' general setup of css, y_train_selec must be real-valued because predictions #' will be generated by ordinary least squares. #' @param X_test A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as X_train_selec, and if the columns #' of X_test are named, they must match the names of X_train_selec. #' @param clusters Optional; either an integer vector of a list of integer #' vectors; each vector should contain the indices of a cluster of features (a #' subset of 1:p). (If there is only one cluster, clusters can either be a list #' of length 1 or an integer vector.) All of the provided clusters must be #' non-overlapping. Any identical (duplicated) clusters will be removed, keeping #' the first occurrence and its name. Every feature not appearing in any cluster #' will be assumed #' to be unclustered (that is, they will be treated as if they are in a #' "cluster" containing only themselves). If clusters is a list of length 0 (or #' a list only containing clusters of length 1), then css() returns the same #' results as stability selection (so feat_sel_mat will be identical to #' clus_sel_mat). Names for the clusters will be needed later; any clusters that #' are not given names in the list clusters will be given names automatically by #' css. CAUTION: if the provided X_train_selec (or X_test) is a data.frame that #' contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). To #' get correct results in this case, please use model.matrix to convert the #' data.frame to a numeric matrix on your own, then provide this matrix and #' cluster assignments with respect to this matrix.Default is list() (so no #' clusters are specified, and every feature is assumed to be in a "cluster" #' containing only itself). #' @param lambda Optional; the tuning parameter to be used by the lasso for #' feature selection in each subsample. If lambda is not provided, cssPredict #' will choose one automatically by cross-validation. Default is NA. #' @param cutoff Numeric; cssPredict will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is NA (in which case, if auto_select_size is TRUE (the default), the #' number of cluster representatives is chosen automatically by cross-validation; #' see auto_select_size). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in X_train_selec and y_train_selec to set aside for #' model training after #' feature selection. If train_inds is not provided, half of the data will be #' used for feature selection and half for model estimation (chosen at random). #' @param auto_select_size Logical; if TRUE, then max_num_clusts will be #' automatically estimated using the lasso with cross-validation. Default is #' TRUE, though this argument is ignored if either cutoff or max_num_clusts is #' provided. (If desired output is to generate predictions using all clusters, #' you should set auto_select_size to FALSE and do not provide cutoff or #' max_num_clusts.) #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Drives both the choice of lambda (when lambda is not provided) and the #' elastic net fit used for feature selection in each subsample. Default is 1 #' (in which case the penalty is the lasso). #' @return A numeric vector of length nrow(X_test) of predictions #' corresponding to the observations from X_test. #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' train <- genClusteredData(n = 80, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' test <- genClusteredData(n = 10, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' preds <- cssPredict(X_train_selec = train$X, y_train_selec = train$y, #' X_test = test$X, clusters = clusters) #' preds #' @export cssPredict <- function(X_train_selec, y_train_selec, X_test, clusters=list(), lambda=NA, cutoff=NA, max_num_clusts=NA, train_inds=NA, auto_select_size=TRUE, alpha=1){ # Check inputs (most inputs will be checked by called functions) if(!is.numeric(y_train_selec) & !is.integer(y_train_selec)){ stop("The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.") } stopifnot(!is.na(auto_select_size)) stopifnot(length(auto_select_size) == 1) stopifnot(is.logical(auto_select_size)) # Validate alpha up front (before the NA-lambda branch and bundling below); # see cssSelect for the ordering rationale. checkAlpha(alpha) stopifnot(is.matrix(X_train_selec) | is.data.frame(X_train_selec)) checkNoNAs(X_train_selec, "X_train_selec") # Reject a non-finite y on the default path (lands after the numeric check # at the top of the function, so the factor-y message there is preserved). checkFiniteY(y_train_selec, "y_train_selec") # Check if x is a matrix; if it's a data.frame, convert to matrix. X_train_selec <- coerceDataFrameToMatrix(X_train_selec, clusters, arg_name = "X_train_selec") stopifnot(is.matrix(X_train_selec)) n <- nrow(X_train_selec) if(any(is.na(train_inds))){ train_inds <- sample(n, size=round(n/2)) } stopifnot(length(lambda) == 1) if(is.na(lambda)){ lambda <- getLassoLambda( X_train_selec[setdiff(1:n, train_inds), , drop = FALSE], y_train_selec[setdiff(1:n, train_inds)], alpha=alpha) } # Bundle alpha into lambda for the elastic-net fit. When alpha == 1 (the # default), leave lambda as a scalar so the pure-lasso path is byte-identical # to the original behavior. if(alpha != 1){ lambda <- c(lambda=lambda, alpha=alpha) } css_results <- css(X=X_train_selec, y=y_train_selec, lambda=lambda, clusters=clusters, train_inds=train_inds) # If no indication of how to select model size was provided, choose model # size by cross-validation if(is.na(cutoff) & is.na(max_num_clusts)){ if(auto_select_size){ max_num_clusts <- getModelSize(X_train_selec[train_inds, , drop = FALSE], y_train_selec[train_inds], css_results$clusters, alpha=alpha) } } if(is.na(cutoff)){ cutoff <- 0 } # Get predictions getCssPreds(css_results, testX=X_test, weighting="weighted_avg", cutoff=cutoff, max_num_clusts=max_num_clusts) } "],["competitor-methods.html", "7 Competitor Methods", " 7 Competitor Methods We also provide implementations of some competitor feature selection methods. We used these in the simulation studies in our paper to compare cluster stability selection to the protolasso (Reid and Tibshirani, 2016) and the cluster representative lasso (Bühlmann et. al. 2013), two other feature selection methods that are designed for data with clustered features. These feature selection methods are in some ways closely related, so their implementations share helper functions. protolasso() processClusterLassoInputs() checks and formats the function inputs getXglmnet() formats the provided design matrix Xglmnet for the lasso as implemented by glmnet (for the protolasso, this means discarding all features from each cluster except the one most highly correlated with the response; for the cluster representative lasso, this means replacing the clustered features with a simple average of the cluster members). checkGetXglmnetInputs() verifies the inputs to getXglmnet() Finally, getClusterSelsFromGlmnet() extracts the relevant output from the results yielded by a glmnet lasso fit. getSelectedSets() takes in a single selected set from Xglmnet and yields a selected feature set in the original feature space (with each selected cluster from Xglmnet replaced by its prototype) as well as a selected set of clusters. clusterRepLasso() The shared core of protolasso() and clusterRepLasso(). The two procedures differ only in how getXglmnet() constructs the design matrix (its type argument); the rest of the body – input handling, the glmnet fit, and extracting selected sets – is identical, so it lives here once. #' Shared implementation of protolasso and clusterRepLasso #' #' Internal helper holding the common body of `protolasso()` and #' `clusterRepLasso()`, which differ only in the `type` passed to `getXglmnet()` #' (the sole point where the two procedures diverge: protolasso discards #' non-prototype cluster members, clusterRepLasso replaces each cluster with its #' representative). #' @param X,y,clusters,nlambda As documented in `protolasso()` / #' `clusterRepLasso()`. #' @param type Character; either "protolasso" or "clusterRepLasso", passed to #' `getXglmnet()` to select the design-matrix construction. #' @return As documented in `protolasso()` / `clusterRepLasso()`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd clusterLassoCore <- function(X, y, clusters, nlambda, type){ # Handle and format inputs; get cluster prototypes ret <- processClusterLassoInputs(X, y, clusters, nlambda) x <- ret$x clusters <- ret$clusters prototypes <- ret$prototypes feat_names <- ret$var_names rm(ret) # Format the design matrix for glmnet according to the chosen procedure # (type = "protolasso" or "clusterRepLasso"); see getXglmnet(). X_glmnet <- getXglmnet(x, clusters, type=type, prototypes=prototypes) # getXglmnet returns one column per cluster, so a single all-encompassing # cluster (or a genuine p < 2 input, which processClusterLassoInputs does not # rule out) yields a 1-column design that glmnet cannot fit ("x should be a # matrix with 2 or more columns"). Fail early with a message naming both # degenerate causes instead of surfacing glmnet's opaque error. This catches # both protolasso() and clusterRepLasso(), which route through here. if(ncol(X_glmnet) < 2){ stop("protolasso()/clusterRepLasso() need at least 2 cluster representatives to fit the lasso, but the provided data yields only 1 (all features are in a single cluster, or p < 2).") } # Estimate the lasso on the cluster prototypes / representatives fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=nlambda) nonzero <- glmnet::predict.glmnet(fit, type="nonzero") # predict.glmnet(type = "nonzero") has no stable container across glmnet # versions, and both operations downstream are container-sensitive: unique() # dedupes list ELEMENTS but data.frame ROWS, and getClusterSelsFromGlmnet()'s # lengths() counts per-element lengths but data.frame ROWS PER COLUMN. So a # SINGLE-COLUMN data.frame here does not error--it returns a confidently # wrong set of model sizes (#190). (The multi-column layout happens to # degenerate to the right answer, because no two of its rows can be equal, so # unique() is a no-op on it. Normalise both anyway: the code should not depend # on which of the two arrives.) # # glmnet 5.0 always returns a list. glmnet 4.x returns one only because this # fit supplies no lambda: the auto-generated sequence starts at lambda_max, # where df == 0, so nonzeroCoef()'s nzel() yields NULL for that penalty, # apply() cannot simplify to a matrix, and 4.x's data.frame(which) coercion # is skipped. That is an accident of the sequence, not a contract, so # normalise rather than rely on it. # # The two data.frame layouts are NOT the same, which is why as.list() alone # would be wrong. When every penalty selected the same NUMBER k >= 2 of # features -- the sets themselves may differ, {1,2} and {2,3} qualify -- # apply() gives a k x n_pen matrix and data.frame() lays out one COLUMN per # penalty. When every penalty selected exactly ONE feature, apply() collapses # to a vector and data.frame() gives a single column with one ROW per # penalty--the convention inverts. n_pen tells them apart. # # Do NOT flatten with unlist(). cssLasso() does, correctly, because its # scalar s gives it exactly one slot; this result has one slot per model # size and flattening would merge them (#188). That function's comment # states the rule and already warns against copying its idiom here; this # one is the full account of nonzeroCoef()'s layouts. They are # complementary, not competing. # # n_pen is ncol(fit$beta) only because this call passes no s. With s # supplied, predict.glmnet interpolates to length(s) columns instead and this # derivation breaks--change n_pen to length(s) if that ever happens. n_pen <- ncol(fit$beta) # The ORDER of the two branch predicates is load-bearing. On a square # input (k == n_pen) BOTH are true and the two readings differ, so testing # ncol first is what makes column-major win -- which is correct, because # apply() simplifies to a matrix only with one column per penalty, and # collapses to a vector (hence exactly one column) otherwise. Swapping the # test and the readings together is wrong on square input only, which is # why a fixture of that shape is pinned below. if(is.data.frame(nonzero)){ nonzero_mat <- as.matrix(nonzero) if(ncol(nonzero_mat) == n_pen){ nonzero <- lapply(seq_len(n_pen), function(j){ as.integer(nonzero_mat[, j]) }) } else{ stopifnot(nrow(nonzero_mat) == n_pen) nonzero <- lapply(seq_len(n_pen), function(i){ as.integer(nonzero_mat[i, ]) }) } } # One slot per penalty in the fitted path, on every glmnet version. Any # other container--nonzeroCoef()'s nr == 1 branch, which the # ncol(X_glmnet) < 2 guard above makes unreachable here--stops rather than # being silently misread downstream. stopifnot(is.list(nonzero)) stopifnot(!is.data.frame(nonzero)) stopifnot(identical(length(nonzero), n_pen)) lasso_sets <- unique(nonzero) # Obtain a tidy list of selected sets--one for each model size cluster_sel_results <- getClusterSelsFromGlmnet(lasso_sets, clusters, prototypes, feat_names) return(list(selected_sets=cluster_sel_results$selected_sets, selected_clusts_list=cluster_sel_results$selected_clusts_list, beta=fit$beta)) } protolasso(): #' Select features via the protolasso (Reid and Tibshirani 2016) #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Any identical #' (duplicated) clusters will be removed, keeping the first occurrence and its #' name. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). #' To get correct results in this case, please use model.matrix to convert #' the data.frame to a numeric matrix on your own, then provide this matrix #' and cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the protolasso. Default is 100 (following the default for glmnet). For #' now, nlambda must be at least 2 (using a single lambda is not supported). #' @return A list with three elements. \\item{selected_sets}{A list of integer #' vectors. Entry k of this list contains a selected set (an integer vector) of #' size k yielded by the protolasso (If no set of size k was selected, entry k #' will be empty.)} \\item{selected_clusts_list}{A list; each element of the list #' is a named list of selected clusters. (That is, if a selected set of size k #' was yielded by the protolasso, then `selected_clusts_list[[k]]` is a named #' list of length k, where each member of the list is an integer vector #' of cluster members. In particular, `selected_clusts_lists[[k]][[j]]` will be #' the cluster that contains feature `selected_sets[[k]][j]`.)} \\item{beta}{The #' beta output from glmnet when the lasso was estimated on a matrix of #' prototypes. (See documentation for the function glmnet from the glmnet #' package for details.) The rows of beta correspond, in order, to the clusters #' in the internally reordered clusters list (the provided clusters in the #' supplied order, followed by a singleton cluster for each unclustered feature #' in ascending feature-index order). Each row name is the cluster's name--the #' provided name for a supplied cluster, or an automatically assigned #' `c<position>` name (position in the reordered list, not the feature index) #' for a singleton; a selected cluster's row name coincides with its entry name #' in `selected_clusts_list[[k]]`.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- protolasso(X = data$X, y = data$y, clusters = clusters) #' str(res, max.level = 1) #' @export protolasso <- function(X, y, clusters=list(), nlambda=100){ clusterLassoCore(X, y, clusters, nlambda, type="protolasso") } processClusterLassoInputs(): #' Check the inputs to protolasso and clusterRepLasso, format clusters, and #' identify prototypes for each cluster #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' Default is list() (so no clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the protolasso. Default is 100 (following the default for glmnet). For #' now, nlambda must be at least 2 (using a single lambda is not supported). #' @return A list with four elements. \\item{x}{The provided X, converted to a #' matrix if it was provided as a data.frame, and with column names removed.} #' \\item{clusters}{A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters are #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features will be put in their own "cluster" of size 1).} #' \\item{prototypes}{An integer vector whose length is equal to the number of #' clusters. Entry i is the index of the feature belonging to cluster i that is #' most highly correlated with y (that is, the prototype for the cluster, as in #' the protolasso; see Reid and Tibshirani 2016).} \\item{var_names}{If the #' provided X matrix had column names, the names of the featurrs in the provided #' X matrix. If no names were provided, feat_names will be NA.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd processClusterLassoInputs <- function(X, y, clusters, nlambda){ stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) feat_names <- as.character(NA) if(!is.null(colnames(X))){ feat_names <- colnames(X) if(any(is.na(feat_names))){ stop("Some features in provided X matrix had valid names and some had NA names; please either name all features in X or remove the names altogether.") } } n <- nrow(X) colnames(X) <- character() stopifnot(is.numeric(y) | is.integer(y)) stopifnot(n == length(y)) stopifnot(all(is.finite(y))) # Check clusters argument clusters <- checkCssClustersInput(clusters) # Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } cluster_results <- formatClusters(clusters, p=ncol(X), clust_names=clust_names, get_prototypes=TRUE, x=X, y=y) clusters <- cluster_results$clusters prototypes <- cluster_results$prototypes rm(cluster_results) stopifnot(length(clusters) == length(prototypes)) stopifnot(is.numeric(nlambda) | is.integer(nlambda)) stopifnot(length(nlambda) == 1) stopifnot(!is.na(nlambda)) stopifnot(nlambda >= 2) stopifnot(nlambda == round(nlambda)) return(list(x=X, clusters=clusters, prototypes=prototypes, var_names=feat_names)) } getXglmnet(): #' Converts the provided design matrix to an appropriate format for either the #' protolasso or the cluster representative lasso. #' #' Creates design matrix for glmnet by dealing with clusters (for #' type="protolasso", discards all cluster members except prototype; for #' type="clusterRepLasso", replaces all cluster members with a simple #' average of all the cluster members). #' @param x A numeric matrix; the provided matrix with n observations and p #' features. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters should #' be equal to the number of clusters.) All identified clusters should be #' non-overlapping. All features should appear in exactly one cluster (any #' unclustered features should be put in their own "cluster" of size 1). #' @param type Character; "protolasso" for the protolasso or "clusterRepLasso" #' for the cluster representative lasso. #' @param prototypes Only required for type "protolasso". An integer vector #' whose length is equal to the number of clusters. Entry i should be the #' prototype for cluster i (the feature belonging to cluster i that is most #' highly correlated with y; see Reid and Tibshirani 2016). #' @return A numeric matrix; the design matrix as required for the protolasso or #' cluster representative lasso, prepared for input to glmnet. #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd getXglmnet <- function(x, clusters, type, prototypes=NA){ # Check inputs checkGetXglmnetInputs(x, clusters, type, prototypes) n <- nrow(x) p <- ncol(x) X_glmnet_cols <- vector("list", length(clusters)) for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] if(length(cluster_i) == 1){ X_glmnet_i <- x[, cluster_i] } else{ stopifnot(length(cluster_i) > 1) if(type == "protolasso"){ prototype_ind_i <- which(prototypes %in% cluster_i) stopifnot(length(prototype_ind_i) == 1) prototype_i <- prototypes[prototype_ind_i] X_glmnet_i <- x[, prototype_i] } else { stopifnot(type == "clusterRepLasso") X_glmnet_i <- rowMeans(x[, cluster_i]) } } stopifnot(length(X_glmnet_i) == n) X_glmnet_cols[[i]] <- X_glmnet_i } # do.call(cbind, ...) reproduces cbind's exact type-promotion (and so # preserves the integer storage of an integer x) while avoiding the # O(n*k^2) copying of growing X_glmnet column by column (#58). X_glmnet <- do.call(cbind, X_glmnet_cols) stopifnot(ncol(X_glmnet) == length(clusters)) stopifnot(ncol(X_glmnet) == length(clusters)) # (#158b) name each column with its cluster's name (from the reordered, # formatted clusters list) so glmnet's beta inherits meaningful rownames # matching selected_clusts_list. Column i corresponds to clusters[[i]]. if(!is.null(names(clusters))){ colnames(X_glmnet) <- names(clusters) } # Check output stopifnot(is.matrix(X_glmnet)) stopifnot(nrow(X_glmnet) == n) stopifnot(ncol(X_glmnet) <= p) stopifnot(ncol(X_glmnet) >= 1) return(X_glmnet) } checkGetXglmnetInputs(): #' Verifies the inputs for getXglmnet. #' #' @param x A numeric matrix; the provided matrix with n observations and p #' features. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters should #' be equal to the number of clusters.) All identified clusters should be #' non-overlapping. All features should appear in exactly one cluster (any #' unclustered features should be put in their own "cluster" of size 1). #' @param type Character; "protolasso" for the protolasso or "clusterRepLasso" #' for the cluster representative lasso. #' @param prototypes Only required for type "protolasso". An integer vector #' whose length is equal to the number of clusters. Entry i should be the #' prototype for cluster i (the feature belonging to cluster i that is most #' highly correlated with y; see Reid and Tibshirani 2016). #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd checkGetXglmnetInputs <- function(x, clusters, type, prototypes){ stopifnot(is.matrix(x)) stopifnot(is.list(clusters)) stopifnot(all(lengths(clusters) >= 1)) stopifnot(length(type) == 1) stopifnot(is.character(type)) stopifnot(!is.na(type)) stopifnot(type %in% c("protolasso", "clusterRepLasso")) stopifnot(!is.na(prototypes)) stopifnot(is.integer(prototypes)) stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) stopifnot(all(prototypes %in% 1:ncol(x))) for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] stopifnot(sum(prototypes %in% cluster_i) == 1) } } getClusterSelsFromGlmnet(): #' Extracts selected clusters and cluster prototypes from the glmnet lasso #' output #' #' @param lasso_sets A list of integer vectors. Each vector represents a set of #' features selected by the lasso for a given value of the penalty parameter #' lambda. The list container is required rather than merely expected: the #' function stops if `lasso_sets` is not a list, or is a data.frame. The #' container only -- element types and lengths are not checked. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features must be in their own "cluster" of size 1). #' @param prototypes An integer vector whose length must be equal to the number #' of clusters. Entry i should be the index of the feature belonging to cluster #' i that is most highly correlated with y (that is, the prototype for the #' cluster, as in the protolasso; see Reid and Tibshirani 2016). #' @param feat_names Character vector; the names of the features in X. (If the #' X provided to protolasso or clusterRepLasso did not have feature names, #' feat_names will be NA.) #' @return A list containing the following items: \\item{selected_sets}{A list of #' integer vectors. Entry k of this list contains a selected set of size k #' yielded by glmnet--each member of the set is the index of a single feature #' from a cluster selected by either the protolasso or the cluster #' representative lasso (the prototype from that cluster--the cluster member #' most highly correlated with y). (If no set of size k was selected, entry k #' will be NULL.)} \\item{selected_clusts_list}{A list of lists; entry k of this #' list is a list of length k of clusters (the clusters that were selected by #' the cluster representative lasso). Again, if no set of size k was selected, #' entry k will be NULL.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. \\cr Bühlmann, P., #' Rütimann, P., van de Geer, S., & Zhang, C. H. (2013). Correlated variables in #' regression: Clustering and sparse estimation. #' \\emph{Journal of Statistical Planning and Inference}, 143(11), 1835–1858. #' \\url{https://doi.org/10.1016/j.jspi.2013.05.019}. #' @keywords internal #' @noRd getClusterSelsFromGlmnet <- function(lasso_sets, clusters, prototypes, feat_names){ # lasso_sets must be a list with one slot per penalty; clusterLassoCore() # normalises predict.glmnet()'s output to that shape. A data.frame is also # a list, so it needs its own test--on one, lengths() below would count # rows per column instead of per-slot lengths, and the function would report # model sizes glmnet never selected (#190). stopifnot(is.list(lasso_sets)) stopifnot(!is.data.frame(lasso_sets)) if(any(!is.na(feat_names))){ stopifnot(all(!is.na(feat_names))) } # Compute each set's length once (used both for max_length and the # per-size subset below) instead of re-walking lengths every iteration (#58) set_lengths <- lengths(lasso_sets) # Largest selected set among all those in lasso_sets max_length <- max(set_lengths) # Preparing lists to store selected_sets <- list() selected_clusts_list <- list() for(j in seq_len(max_length)){ # Lasso selected set of size j lasso_sets_j <- lasso_sets[set_lengths == j] # Are there any lasso selected sets of size j? (If not, we will skip to # the next j, and slot j in the list will be empty.) if(length(lasso_sets_j) > 0){ # Select the first set of size j lasso_set_j <- lasso_sets_j[[1]] stopifnot(length(lasso_set_j) == j) ret <- getSelectedSets(lasso_set=lasso_set_j, clusters=clusters, prototypes=prototypes, feat_names=feat_names) selected_sets[[j]] <- ret$selected_set selected_clusts_list[[j]] <- ret$selected_clusts_list rm(ret) } } stopifnot(length(selected_sets) <= max_length) stopifnot(length(selected_clusts_list) <= max_length) return(list(selected_sets=selected_sets, selected_clusts_list=selected_clusts_list)) } getSelectedSets(): #' Converts a selected set from X_glmnet to selected sets and selected clusters #' from the original feature space of X. #' #' @param lasso_set A vector containing the indices of selected cluster #' representatives or prototypes. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features must be in their own "cluster" of size 1). #' @param prototypes An integer vector whose length must be equal to the number #' of clusters. Entry i should be the index of the feature belonging to cluster #' i that is most highly correlated with y (that is, the prototype for the #' cluster, as in the protolasso). #' @param feat_names Character vector; the names of the features in X. #' @return A list containing two items: \\item{selected_set}{An integer vector #' with length equal to lasso_set containing a set of selected features in the #' original X matrix. (Selections in lasso_set corresponding to a cluster will #' be replaced by the cluster's prototype from X.)} #' \\item{selected_clusts_list}{A named list of integer vectors with length equal #' to selected_set. `selected_clusts_list[[k]]` will be an integer vector #' containing the indices of the features in X that are in the cluster #' containing prototype `selected_set[k]`.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectedSets <- function(lasso_set, clusters, prototypes, feat_names){ model_size <- length(lasso_set) stopifnot(model_size > 0) stopifnot(length(unique(lasso_set)) == model_size) stopifnot(all(lasso_set <= length(clusters))) selected_set <- integer() selected_clusts_list <- list() # (#158a) preserve each selected cluster's name so selected_clusts_list is # the named list the docs promise (its names match beta's rownames, #158b). clust_names_out <- character(model_size) # Recover features from original feature space for(k in 1:model_size){ selected_cluster_k <- clusters[[lasso_set[k]]] stopifnot(is.integer(selected_cluster_k)) selected_clusts_list[[k]] <- selected_cluster_k if(!is.null(names(clusters))){ clust_names_out[k] <- names(clusters)[lasso_set[k]] } if(length(selected_cluster_k) == 1){ stopifnot(!(selected_cluster_k %in% selected_set)) selected_set <- c(selected_set, selected_cluster_k) } else{ sel_prototype <- which(prototypes %in% selected_cluster_k) stopifnot(length(sel_prototype) == 1) stopifnot(!(prototypes[sel_prototype] %in% selected_set)) selected_set <- c(selected_set, prototypes[sel_prototype]) } } # (#158a) name the returned list with the selected clusters' names so it is # the named list documented for protolasso()/clusterRepLasso(). if(!is.null(names(clusters))){ names(selected_clusts_list) <- clust_names_out } stopifnot(length(selected_set) == model_size) stopifnot(length(unique(selected_set)) == model_size) if(any(!is.na(feat_names))){ names(selected_set) <- feat_names[selected_set] } stopifnot(length(selected_clusts_list) == model_size) all_feats <- unlist(selected_clusts_list) stopifnot(length(all_feats) == length(unique(all_feats))) return(list(selected_set=selected_set, selected_clusts_list=selected_clusts_list)) } clusterRepLasso(): #' Select features via the cluster representative lasso (Bühlmann et. al. 2013) #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Any identical #' (duplicated) clusters will be removed, keeping the first occurrence and its #' name. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). #' To get correct results in this case, please use model.matrix to convert #' the data.frame to a numeric matrix on your own, then provide this matrix #' and cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the cluster representative lasso. Default is 100 (following the default #' for glmnet). For now, nlambda must be at least 2 (using a single lambda is #' not supported). #' @return A list with three elements. \\item{selected_sets}{A list of integer #' vectors. Entry k of this list contains a selected set (an integer vector) of #' size k yielded by the lasso--each member of the set is the index of a single #' feature from a cluster selected by the cluster representative lasso (the #' prototype from that cluster--the cluster member most highly correlated with #' y). (If no set of size k was selected, entry k will be empty.)} #' \\item{selected_clusts_list}{A list; each element of the list is a named list #' of selected clusters. (That is, if a selected set of size k was yielded by #' the cluster representative lasso, then `selected_clusts_list[[k]]` is a named #' list of length k, where each member of the list is an integer vector #' of cluster members. Note that `selected_clusts_lists[[k]][[j]]` will be the #' cluster that contains feature `selected_sets[[k]][j]`.)} \\item{beta}{The beta #' output from glmnet when the lasso was estimated on a matrix of cluster #' representatives (simple averages of the cluster members). (See documentation #' for the function glmnet from the glmnet package for details.) The rows of #' beta correspond, in order, to the clusters in the internally reordered #' clusters list (the provided clusters in the supplied order, followed by a #' singleton cluster for each unclustered feature in ascending feature-index #' order). Each row name is the cluster's name--the provided name for a supplied #' cluster, or an automatically assigned `c<position>` name (position in the #' reordered list, not the feature index) for a singleton; a selected cluster's #' row name coincides with its entry name in `selected_clusts_list[[k]]`.} #' @author Gregory Faletto, Jacob Bien #' @references Bühlmann, P., Rütimann, P., van de Geer, S., & Zhang, C. H. #' (2013). Correlated variables in regression: Clustering and sparse estimation. #' \\emph{Journal of Statistical Planning and Inference}, 143(11), 1835–1858. #' \\url{https://doi.org/10.1016/j.jspi.2013.05.019}. \\cr Jerome Friedman, Trevor #' Hastie, Robert Tibshirani (2010). Regularization Paths for Generalized Linear #' Models via Coordinate Descent. \\emph{Journal of Statistical Software}, 33(1) #' 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- clusterRepLasso(X = data$X, y = data$y, clusters = clusters) #' str(res, max.level = 1) #' @export clusterRepLasso <- function(X, y, clusters=list(), nlambda=100){ clusterLassoCore(X, y, clusters, nlambda, type="clusterRepLasso") } "],["tests-for-the-core-css-functions.html", "8 Tests for the core css() functions", " 8 Tests for the core css() functions Now that all of the package’s functions have been defined, we collect their tests here, grouped to mirror the definition chapters above. Keeping the tests together at the end lets those chapters read as continuous narrative; because every function is defined before this part, each test runs only after all of its dependencies have been defined. Tests for coerceDataFrameToMatrix(): testthat::test_that("coerceDataFrameToMatrix keeps a single-column data.frame as a matrix (#43)", { # A 1-column data.frame must coerce to a 1-column matrix, not collapse to a # vector (which used to crash with the cryptic "argument is of length zero", # both with and without clusters). num_df <- data.frame(a = as.numeric(1:8)) res_clust <- coerceDataFrameToMatrix(num_df, clusters = list(1)) testthat::expect_true(is.matrix(res_clust)) testthat::expect_equal(dim(res_clust), c(8L, 1L)) res_noclust <- coerceDataFrameToMatrix(num_df, clusters = list()) testthat::expect_true(is.matrix(res_noclust)) testthat::expect_equal(dim(res_noclust), c(8L, 1L)) # A matrix passes through unchanged. m <- matrix(as.numeric(1:8), nrow = 8, ncol = 1) testthat::expect_identical(coerceDataFrameToMatrix(m, clusters = list()), m) # The factor-expansion guard still fires (a >= 3-level factor changes ncol). fac_df <- data.frame(a = factor(c("x", "y", "z", "x", "y", "z", "x", "y"))) testthat::expect_error(coerceDataFrameToMatrix(fac_df, clusters = list(1)), "the number of columns changed", fixed = TRUE) # A non-numeric (character) matrix is rejected (#152). testthat::expect_error( coerceDataFrameToMatrix(matrix(letters[1:6], nrow = 3, ncol = 2), clusters = list()), "must be a numeric matrix", fixed = TRUE) }) ## Test passed with 7 successes. Tests that a non-numeric matrix X is rejected at every X entry point (#152). All seven entry points funnel through coerceDataFrameToMatrix(), so a character matrix errors with the same clear message everywhere instead of silently producing all-zero selections (css) or crashing later (protolasso): testthat::test_that("non-numeric matrix X is rejected at every entry point (#152)", { set.seed(1) cx <- matrix(sample(letters, 20, TRUE), 10, 2) # character matrix testthat::expect_error( css(X = cx, y = stats::rnorm(10), lambda = 0.01, B = 5), "must be a numeric matrix", fixed = TRUE) testthat::expect_error( protolasso(matrix(sample(letters, 40, TRUE), 20, 2), stats::rnorm(20)), "must be a numeric matrix", fixed = TRUE) testthat::expect_error( clusterRepLasso(matrix(sample(letters, 40, TRUE), 20, 2), stats::rnorm(20)), "must be a numeric matrix", fixed = TRUE) # getCssPreds(testX = <character matrix>): build a valid css result on # numeric data, then pass a character testX of the SAME ncol so it # reaches coerceDataFrameToMatrix (not an ncol-mismatch check first). nx <- matrix(stats::rnorm(60), 30, 2) # B = 5 is under checkB()'s B < 10 threshold, so css() deliberately warns # here. Assert it rather than letting it leak into the reporter (#186). # The assignment sits inside expect_warning() because at testthat edition # 3 expect_warning() returns the condition, not the expression's value. testthat::expect_warning( res <- css(X = nx[1:20, ], y = stats::rnorm(20), lambda = 0.01, B = 5), "Small values of B may lead to poor results.", fixed = TRUE) testthat::expect_error( getCssPreds(res, testX = matrix(sample(letters, 20, TRUE), 10, 2), trainX = nx[21:30, ], trainY = stats::rnorm(10)), "must be a numeric matrix", fixed = TRUE) }) ## Test passed with 5 successes. Tests for checkNoNAs(): testthat::test_that("checkNoNAs flags NA/NaN/Inf in a matrix or data.frame and passes clean input", { m_ok <- matrix(as.numeric(1:8), nrow = 4, ncol = 2) testthat::expect_identical(checkNoNAs(m_ok, "X"), m_ok) # returns input invisibly m_na <- m_ok; m_na[2, 1] <- NA testthat::expect_error(checkNoNAs(m_na, "X"), "must not contain missing", fixed = TRUE) # data.frame with a numeric NA is caught too (before any coercion). df_na <- data.frame(a = c(1, NA, 3), b = c(4, 5, 6)) testthat::expect_error(checkNoNAs(df_na, "X"), "must not contain missing", fixed = TRUE) # arg_name appears in the message. testthat::expect_error(checkNoNAs(m_na, "newx"), "newx", fixed = TRUE) # Non-finite values are rejected too (#99): is.na(Inf) is FALSE, so the # previous bare is.na() check let Inf/-Inf slip through into glmnet and the # cluster-representative averaging, silently corrupting results. m_inf <- m_ok; m_inf[2, 1] <- Inf testthat::expect_error(checkNoNAs(m_inf, "X"), "non-finite", fixed = TRUE) m_neginf <- m_ok; m_neginf[3, 2] <- -Inf testthat::expect_error(checkNoNAs(m_neginf, "X"), "non-finite", fixed = TRUE) # NaN is caught by is.na() (is.na(NaN) is TRUE). m_nan <- m_ok; m_nan[1, 1] <- NaN testthat::expect_error(checkNoNAs(m_nan, "X"), "must not contain missing", fixed = TRUE) # data.frame with Inf in a numeric column is rejected too. df_inf <- data.frame(a = c(1, Inf, 3), b = c(4, 5, 6)) testthat::expect_error(checkNoNAs(df_inf, "X"), "non-finite", fixed = TRUE) # A finite data.frame passes through unchanged. df_ok <- data.frame(a = c(1, 2, 3), b = c(4, 5, 6)) testthat::expect_identical(checkNoNAs(df_ok, "X"), df_ok) # A data.frame with non-numeric (factor/character) columns plus clean numeric # columns still passes: the is.infinite() check is per-numeric-column, so it # must not false-positive on non-numeric columns. df_mixed <- data.frame( f = factor(c("x", "y", "z")), s = c("a", "b", "c"), n = c(1, 2, 3), stringsAsFactors = FALSE) testthat::expect_identical(checkNoNAs(df_mixed, "X"), df_mixed) }) ## Test passed with 10 successes. Tests for checkFiniteY(): testthat::test_that("checkFiniteY accepts finite numeric/integer y and rejects non-finite or non-numeric y (#100)", { # Finite numeric and integer y pass, returning the input invisibly. y_num <- as.numeric(1:8) * 0.5 testthat::expect_identical(checkFiniteY(y_num, "y"), y_num) y_int <- 1L:8L testthat::expect_identical(checkFiniteY(y_int, "y"), y_int) testthat::expect_invisible(checkFiniteY(y_num, "y")) # NA, NaN, Inf, -Inf each error with the non-finite message. testthat::expect_error(checkFiniteY(c(1, NA, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, NaN, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, Inf, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, -Inf, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) # A non-numeric (logical/character) y errors with the numeric message. testthat::expect_error(checkFiniteY(c(TRUE, FALSE, TRUE), "y"), "must be a numeric (real-valued) vector", fixed = TRUE) testthat::expect_error(checkFiniteY(c("a", "b"), "y"), "must be a numeric (real-valued) vector", fixed = TRUE) # arg_name is interpolated into both messages. testthat::expect_error(checkFiniteY(c(1, Inf), "y_train_selec"), "The provided y_train_selec must not contain missing", fixed = TRUE) testthat::expect_error(checkFiniteY(c(TRUE, FALSE), "y_train_selec"), "The provided y_train_selec must be a numeric", fixed = TRUE) }) ## Test passed with 11 successes. tests for checkCssClustersInput: testthat::test_that("checkCssClustersInput works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) res <- checkCssClustersInput(good_clusters) # clusters testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), length(names(res))) testthat::expect_equal(length(res), length(unique(names(res)))) testthat::expect_true(all(!is.na(names(res)))) testthat::expect_true(all(!is.null(names(res)))) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) res <- checkCssClustersInput(unnamed_clusters) # clusters testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) testthat::expect_error(checkCssClustersInput(list(1:4, 4:6)), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): the result is identical # to passing the cluster only once. testthat::expect_identical(checkCssClustersInput(list(2:3, 2:3)), list(2:3)) testthat::expect_error(checkCssClustersInput(list(2:3, as.integer(NA))), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(list(2:3, c(4, 4, 5))), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(list(2:3, -1)), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(c(0.4, 0.6)), "all(clusters == round(clusters)) is not TRUE", fixed=TRUE) # Single cluster res_sing_clust <- checkCssClustersInput(2:5) testthat::expect_equal(length(res_sing_clust), 4) }) ## Test passed with 17 successes. Tests for checkY(): testthat::test_that("checkY works", { testthat::expect_null(checkY(as.numeric(1:20)*.1, 20)) testthat::expect_null(checkY(1L:15L, 15)) testthat::expect_error(checkY(1:7, 8), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(checkY(1:7, -7), "n > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkY(rep(as.numeric(NA), 13), 13), "all(is.finite(y)) is not TRUE", fixed=TRUE) # Inf is now rejected too (previously all(!is.na(y)) missed it) (#100) testthat::expect_error(checkY(c(1, Inf, 3), 3), "all(is.finite(y)) is not TRUE", fixed=TRUE) testthat::expect_error(checkY(rep(5.2, 9), 9), "length(unique(y)) > 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkY(c(TRUE, FALSE, TRUE), 3), "is.numeric(y) | is.integer(y) is not TRUE", fixed=TRUE) }) ## Test passed with 8 successes. Tests for checkFormatClustersInput(): testthat::test_that("checkFormatClustersInput works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) res <- checkFormatClustersInput(good_clusters, p=10, clust_names=c("red_cluster", "green_cluster"), get_prototypes=FALSE, x=NA, y=NA, R=NA) testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) res <- checkFormatClustersInput(unnamed_clusters, p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA) # clusters testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) testthat::expect_error(checkFormatClustersInput(list(1:4, 4:6), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "length(intersect(clusters[[i]], clusters[[j]])) == 0 is not TRUE", fixed=TRUE) # Duplicate clusters are now silently removed (#156). testthat::expect_identical(checkFormatClustersInput(list(2:3, 2:3), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), list(2:3)) testthat::expect_error(checkFormatClustersInput(list(2:3, as.integer(NA)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "Must specify one of clusters or R (or does one of these provided inputs contain NA?)", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(2:3, c(4, 4, 5)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(1:4, -1), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(1:4, c(2.3, 1.2)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "is.integer(clusters[[i]]) is not TRUE", fixed=TRUE) # Single cluster testthat::expect_true(is.list(checkFormatClustersInput(c(1:5), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA))) }) ## Test passed with 13 successes. Tests for checkClusters(): testthat::test_that("checkClusters works", { good_clusters <- list(c1=1L:5L, c2=6L:8L, c3=9L) testthat::expect_null(checkClusters(good_clusters, 9)) testthat::expect_error(checkClusters(good_clusters, 10), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(1L:10L, 10), "is.list(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=integer()), 9), "all(lengths(clusters) >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=as.integer(NA)), 9), "all(!is.na(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c2=6L:8L), 9), "n_clusters == length(unique(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=10L), 9), "all(all_clustered_feats <= p) is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Tests for identifyPrototype(): testthat::test_that("identifyPrototype works", { testthat::expect_identical(identifyPrototype(10L, "a", 5), 10L) n <- 10 p <- 5 set.seed(9834) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] testthat::expect_equal(identifyPrototype(as.integer(p), X, y), p) testthat::expect_equal(identifyPrototype(2L, X, y), 2) testthat::expect_equal(identifyPrototype(as.integer(2:p), X, y), p) testthat::expect_error(identifyPrototype(as.integer(2:p), y, X), "incorrect number of dimensions", fixed=TRUE) y2 <- rnorm(n) res <- identifyPrototype(c(2L, 3L), X, y2) testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 1) testthat::expect_true(res %in% c(2L, 3L)) }) testthat::test_that("identifyPrototype handles a constant cluster member silently (#59)", { # A constant column has undefined correlation; the vectorized cor() path # returns 0 for it -- and SILENTLY (base cor() warns "the standard deviation # is zero" on a constant column; identifyPrototype now suppresses that to # preserve the silent-0 contract). n <- 12 set.seed(7321) varying <- stats::rnorm(n) # Column 1 is constant; column 2 equals y (perfectly correlated). x <- cbind(rep(1.5, n), varying) y <- varying # The prototype must be the varying member (2), never the constant column (1). testthat::expect_identical(identifyPrototype(c(1L, 2L), x, y), 2L) # And no "standard deviation is zero" warning may leak. testthat::expect_silent(identifyPrototype(c(1L, 2L), x, y)) }) testthat::test_that("identifyPrototype warns on a constant response y (#67)", { # Moved from the removed helper's test: a constant y makes every # cluster-member correlation undefined, and identifyPrototype warns. set.seed(5417) X <- matrix(stats::rnorm(8 * 2), nrow = 8, ncol = 2) y_const <- rep(2.5, 8) testthat::expect_warning( identifyPrototype(c(1L, 2L), X, y_const), "identifyPrototype: the response y has only one unique value", fixed = TRUE) }) testthat::test_that("identifyPrototype selects by absolute correlation (#67)", { # The prototype is the member with the largest ABSOLUTE correlation with y, so # a near-perfectly NEGATIVELY correlated member must beat a weak positive one. set.seed(6708) n <- 20 y <- stats::rnorm(n) X <- cbind(-y, y + stats::rnorm(n, sd = 4)) # col 1: cor=-1; col 2: weak +cor # abs() => col 1 (|cor|=1) wins despite its negative sign. testthat::expect_identical(identifyPrototype(c(1L, 2L), X, y), 1L) }) ## Test passed with 8 successes. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 1 success. Tests for getPrototypes() testthat::test_that("getPrototypes works", { n <- 10 p <- 5 set.seed(902689) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] testthat::expect_identical(getPrototypes(list(1L, 2L, 3L, 4L, 5L), X, y), 1:5) testthat::expect_identical(getPrototypes(list(1L:5L), X, y), 5L) testthat::expect_identical(getPrototypes(list(1L, 2L:5L), X, y), c(1L, 5L)) testthat::expect_identical(getPrototypes(list(3L:5L), X, y), 5L) y2 <- rnorm(n) res <- getPrototypes(list(1L, c(2L, 3L), c(4L, 5L)), X, y2) testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(res[1], 1L) testthat::expect_true(res[2] %in% c(2L, 3L)) testthat::expect_true(res[3] %in% c(4L, 5L)) testthat::expect_error(getPrototypes(list(1L, 2L, 3L, 4L, 5L), y, X), "is.matrix(x) is not TRUE", fixed=TRUE) testthat::expect_error(getPrototypes(list(1L, 2L, 3L, 4L, 5L), X, y[1:9]), "n == length(y) is not TRUE", fixed=TRUE) }) ## Test passed with 11 successes. Finally, tests for formatClusters(): testthat::test_that("formatClusters works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1:3, 5:8) res <- formatClusters(good_clusters, p=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("clusters", "multiple")) # Clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), 5) testthat::expect_equal(5, length(names(res$clusters))) testthat::expect_equal(5, length(unique(names(res$clusters)))) testthat::expect_true("red_cluster" %in% names(res$clusters)) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) testthat::expect_true(all(names(res$clusters) != "")) clust_feats <- integer() true_list <- list(1:3, 5:8, 4, 9, 10) for(i in 1:length(res$clusters)){ testthat::expect_true(is.integer(res$clusters[[i]])) testthat::expect_equal(length(intersect(clust_feats, res$clusters[[i]])), 0) testthat::expect_true(all(res$clusters[[i]] %in% 1:10)) testthat::expect_equal(length(res$clusters[[i]]), length(unique(res$clusters[[i]]))) testthat::expect_true(all(res$clusters[[i]] == true_list[[i]])) clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), 10) testthat::expect_equal(10, length(unique(clust_feats))) testthat::expect_equal(10, length(intersect(clust_feats, 1:10))) # Multiple testthat::expect_true(res$multiple) testthat::expect_false(formatClusters(3:5, p=10)$multiple) ## Trying other inputs testthat::expect_error(formatClusters(list(3:7, 7:10), p=15), "length(intersect(clusters[[i]], clusters[[j]])) == 0 is not TRUE", fixed=TRUE) # Duplicate clusters are now silently removed (#156): dropping the duplicate # 5:8 leaves the same 6 formatted clusters (5:8 plus five singletons) as # passing 5:8 once, with multiple = FALSE and 5:8 appearing exactly once. dedup_fc <- formatClusters(list(5:8, 5:8), p=9) testthat::expect_identical(dedup_fc, formatClusters(list(5:8), p=9)) testthat::expect_equal(length(dedup_fc$clusters), 6) testthat::expect_false(dedup_fc$multiple) testthat::expect_equal(sum(vapply(dedup_fc$clusters, function(z) identical(as.integer(z), 5:8), logical(1))), 1) # Out-of-range cluster index is now caught up front by checkFormatClustersInput # (#104, L3) with a message naming the offending index and p, instead of the # downstream cryptic length(all_clustered_feats) == p stopifnot. testthat::expect_error(formatClusters(list(5:8), p=7), "Cluster index 8 exceeds the number of features (p = 7).", fixed=TRUE) testthat::expect_error(formatClusters(list(2:3, as.integer(NA)), p=10), "Must specify one of clusters or R (or does one of these provided inputs contain NA?)", fixed=TRUE) testthat::expect_error(formatClusters(list(2:3, c(4, 4, 5)), p=8), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(list(1:4, -1), p=10), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(list(1:4, c(2.3, 1.2))), "is.integer(clusters[[i]]) is not TRUE", fixed=TRUE) ### Test prototypes feature n <- 8 p <- 6 set.seed(690289) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] res <- formatClusters(clusters=list(), p=p, get_prototypes=TRUE, x=X, y=y) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("clusters", "multiple", "prototypes")) testthat::expect_true(is.integer(res$prototypes)) testthat::expect_identical(res$prototypes, 1:p) testthat::expect_equal(formatClusters(clusters=1:p, p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, p) testthat::expect_identical(formatClusters(clusters=list(1L, 2L:p), p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, as.integer(c(1, p))) testthat::expect_identical(formatClusters(clusters=3L:p, p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, as.integer(c(p, 1, 2))) y2 <- rnorm(n) res <- formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=X, y=y2)$prototypes testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 4) testthat::expect_true(res[1] %in% c(2L, 3L)) testthat::expect_true(res[2] %in% c(4L, 5L)) testthat::expect_equal(res[3], 1L) testthat::expect_equal(res[4], p) testthat::expect_error(formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=y2, y=X), "is.matrix(x) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=X, y=y2[1:(n-1)]), "n == length(y) is not TRUE", fixed=TRUE) }) ## Test passed with 65 successes. Tests for checkSamplingType(): testthat::test_that("checkSamplingType works", { testthat::expect_null(checkSamplingType("SS")) testthat::expect_error(checkSamplingType("MB"), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) testthat::expect_error(checkSamplingType(c("SS", "SS")), "length(sampling_type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkSamplingType(1), "is.character(sampling_type) is not TRUE", fixed=TRUE) testthat::expect_error(checkSamplingType(as.character(NA)), "!is.na(sampling_type) is not TRUE", fixed=TRUE) }) ## Test passed with 5 successes. Tests for checkB(): testthat::test_that("checkB works", { testthat::expect_null(checkB(1500)) testthat::expect_null(checkB(15)) testthat::expect_error(checkB("B"), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(20:25), "length(B) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkB(as.integer(NA)), "!is.na(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(1.2), "B == round(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(-100), "B > 0 is not TRUE", fixed=TRUE) testthat::expect_warning(checkB(5), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_warning(checkB(2200), "Large values of B may require long computation times.", fixed=TRUE) }) ## Test passed with 9 successes. Tests for checkAlpha(): testthat::test_that("checkAlpha validates alpha in (0, 1] (#72)", { testthat::expect_null(checkAlpha(1)) testthat::expect_null(checkAlpha(0.5)) testthat::expect_error(checkAlpha("0.5"), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(c(0.5, 0.6)), "length(alpha) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(NA_real_), "!is.na(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(0), "alpha > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(1.5), "alpha <= 1 is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Tests for checkPropFeatsRemove(): testthat::test_that("checkPropFeatsRemove works", { testthat::expect_null(checkPropFeatsRemove(0, 5)) testthat::expect_null(checkPropFeatsRemove(.3, 10)) testthat::expect_error(checkPropFeatsRemove(1, 3), "prop_feats_remove >= 0 & prop_feats_remove < 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(c(.5, .6), 17), "length(prop_feats_remove) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(".3", 99), "is.numeric(prop_feats_remove) | is.integer(prop_feats_remove) is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(as.numeric(NA), 172), "!is.na(prop_feats_remove) is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(.1, 1), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Finally, tests for checkCssInputs(): testthat::test_that("checkCssInputs works", { set.seed(80526) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L # , c4=10:11 ) res <- checkCssInputs(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) # Basic output testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("feat_names", "X", "clusters")) # feat_names testthat::expect_true(is.character(res$feat_names)) testthat::expect_true(is.na(res$feat_names)) testthat::expect_equal(length(res$feat_names), 1) # X testthat::expect_true(is.matrix(res$X)) testthat::expect_true(all(!is.na(res$X))) testthat::expect_true(is.numeric(res$X)) testthat::expect_equal(ncol(res$X), 11) testthat::expect_equal(nrow(res$X), 15) # clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), length(names(res$clusters))) testthat::expect_equal(length(res$clusters), length(unique(names(res$clusters)))) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) clust_feats <- integer() for(i in 1:length(res$clusters)){ clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:11))) # Regression test: train_inds with an out-of-range index (> n) must be # rejected. Previously the upper-bound check was a no-op due to a misplaced # parenthesis (all(train_inds) <= n instead of all(train_inds <= n)), so # out-of-range indices were silently accepted. (n = 15 here; 16 is invalid.) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = c(1L, 2L, 16L), num_cores = 1L)) ## Trying other inputs # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } res_fitfun <- checkCssInputs(X=x, y=y, lambda=x, clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) testthat::expect_true(is.list(res_fitfun)) # Single cluster res_sing_clust <- checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) testthat::expect_true(is.list(res_sing_clust)) testthat::expect_equal(length(res_sing_clust$clusters), 11 - 3 + 1) testthat::expect_true(length(unique(names(res_sing_clust$clusters))) == 11 - 3 + 1) testthat::expect_true(all(!is.na(names(res_sing_clust$clusters)))) testthat::expect_true(all(!is.null(names(res_sing_clust$clusters)))) # Other sampling types testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "MB", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "S", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L)) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = 2, B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "is.character(sampling_type) is not TRUE", fixed=TRUE) # B testthat::expect_warning(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 5, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = "foo", prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) # prop_feats_remove testthat::expect_true(is.list(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun=testFitfun, sampling_type = "SS", B = 12, prop_feats_remove = 0.3, train_inds = integer(), num_cores = 1L))) # Use train_inds argument testthat::expect_true(is.list(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun=testFitfun, sampling_type = "SS", B = 12, prop_feats_remove = 0.3, train_inds = 11:15, num_cores = 1L))) }) ## Test passed with 31 successes. Tests for checkCssLoopOutput(): testthat::test_that("checkCssLoopOutput works", { testthat::expect_null(checkCssLoopOutput(selected=1:5, p=6, feats_on_subsamp=1:6)) testthat::expect_error(checkCssLoopOutput(selected=1:5, p=4, feats_on_subsamp=1:6), "The provided feature selection method fitfun returned a vector of selected features longer than p on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=1:5, p=7, feats_on_subsamp=1:4), "The provided feature selection method somehow selected features that were not provided for it to consider.", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(1, 2, 3, 4.4, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun failed to return a vector of valid (integer) indices on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=rep(1, 3), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing repeated indices on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(-1, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(0, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=as.integer(NA), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector containing NA values on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c("1", "2", "3"), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun failed to return an integer or numeric vector on (at least) one subsample", fixed=TRUE) testthat::expect_error( checkCssLoopOutput(selected=c(TRUE, FALSE), p=7, feats_on_subsamp=1:7), "returned a logical vector", fixed=TRUE) testthat::expect_error( checkCssLoopOutput(selected=NULL, p=7, feats_on_subsamp=1:7), "returned NULL", fixed=TRUE) }) ## Test passed with 11 successes. Tests for fitfunFailureMessage(): testthat::test_that("fitfunFailureMessage surfaces the cause and subsample index (#73)", { # try-error path: the wrapped condition message is surfaced (this is what # getSelMatrix actually receives from mclapply under forking). te <- structure("Error\\n", class = "try-error", condition = simpleError("fitfun returned a character vector")) msg <- fitfunFailureMessage(te, 4L) testthat::expect_match(msg, "subsample 4", fixed = TRUE) testthat::expect_match(msg, "fitfun returned a character vector", fixed = TRUE) # defensive non-try-error fallback: the class is reported. msg2 <- fitfunFailureMessage("not an integer vector", 2L) testthat::expect_match(msg2, "class character", fixed = TRUE) testthat::expect_match(msg2, "subsample 2", fixed = TRUE) testthat::expect_match(msg2, "integer vector of selected feature indices", fixed = TRUE) }) ## Test passed with 5 successes. Tests for checkCssLassoInputs(): testthat::test_that("checkCssLassoInputs works", { set.seed(761) x <- matrix(stats::rnorm(15*4), nrow=15, ncol=4) y <- stats::rnorm(15) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=0.01)) testthat::expect_error(checkCssLassoInputs(X=x, y=logical(15), lambda=0.05), "For method cssLasso, y must be a numeric or integer vector.", fixed=TRUE) # Integer y is accepted (is.numeric(1L) is TRUE; the | !is.integer guard # makes the validator read uniformly with the other entry points). Regression # test for issue #13 -- this is NOT a behavior change, integer y always worked. testthat::expect_null(checkCssLassoInputs(X=x, y=as.integer(round(y * 10)), lambda=0.01)) testthat::expect_error(checkCssLassoInputs(X=x[1:13, ], y=y, lambda=0.01), "For method cssLasso, y must be a vector of length equal to nrow(X).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=rep(1.2, 15), lambda=0.05), "Subsample with only one unique value of y detected: for the default cssLasso, every subsample of y (of size floor(n/2)) must have more than one unique value. css draws random subsamples, so this abort is seed-dependent and becomes more likely as B grows. It indicates that y is too discrete for the default cssLasso--supply a less discrete (more continuous) response, or pass a custom fitfun that tolerates a constant-y subsample.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=TRUE), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=as.numeric(NA)), "NA detected in provided lambda input to cssLasso", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=x), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=numeric()), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) # Bundled c(lambda=, alpha=) form (elastic net) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0.5))) # Order-insensitive (setequal on names) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(alpha=0.5, lambda=0.1))) # alpha at the boundary 1 is allowed testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=1))) # Unnamed length-2 vector is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(0.1, 0.5)), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0)), "For method cssLasso, the alpha component of lambda must be in (0, 1].", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=1.2)), "For method cssLasso, the alpha component of lambda must be in (0, 1].", fixed=TRUE) # Length-3 vector is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0.5, extra=0.3)), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) }) ## Test passed with 18 successes. Tests for cssLasso() confirming that the elastic net mixing parameter alpha, bundled into lambda as c(lambda=, alpha=), actually changes which features are selected (and that the default pure-lasso path is unchanged). On a design with a correlated block of relevant features, a smaller alpha (more ridge-like) pulls in the correlated block partners that the pure lasso drops, so the elastic-net selected set is a strict superset of the lasso selected set: testthat::test_that("cssLasso alpha (bundled in lambda) drives selection", { # Correlated-block design: features 1-4 are relevant and share a common # latent factor at correlation rho; features 5-20 are irrelevant noise. set.seed(1) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), n, p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) L <- 3.72251 s_lasso <- cssLasso(Z, y, lambda=c(lambda=L, alpha=1)) s_enet <- cssLasso(Z, y, lambda=c(lambda=L, alpha=0.2)) # Pure lasso selects only the two strongest block members; the elastic net # pulls in the full correlated block. testthat::expect_identical(s_lasso, c(3L, 4L)) testthat::expect_identical(s_enet, c(1L, 2L, 3L, 4L)) # The elastic-net set is a strict superset of the lasso set (the round-2 # cosmetic: robust to L within +/-10%). testthat::expect_true(all(s_lasso %in% s_enet)) testthat::expect_true(length(setdiff(s_enet, s_lasso)) > 0) # Back-compatibility: a scalar lambda is byte-identical to the bundled form # with alpha = 1 (the default pure-lasso path is unchanged). testthat::expect_identical(cssLasso(Z, y, lambda=L), cssLasso(Z, y, lambda=c(lambda=L, alpha=1))) }) ## Test passed with 5 successes. Tests for cssLoop() (had to define checkCssLassoInputs() first): testthat::test_that("cssLoop works", { set.seed(89134) x <- matrix(stats::rnorm(9*8), nrow=9, ncol=8) y <- stats::rnorm(9) output <- cssLoop(input=1L:4L, x=x, y=y, lambda=0.05, fitfun=cssLasso) testthat::expect_true(is.integer(output)) testthat::expect_equal(length(output), length(unique(output))) testthat::expect_true(length(output) <= 8) testthat::expect_true(all(output >= 1)) testthat::expect_true(all(output <= 8)) testthat::expect_error(cssLoop(input=1L:6L, x=x, y=y, lambda=0.05, fitfun=cssLasso), "floor(n/2) == length(subsample) is not TRUE", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=y[1:8], lambda=0.05, fitfun=cssLasso), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=logical(9), lambda=0.05, fitfun=cssLasso), "For method cssLasso, y must be a numeric or integer vector.", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=y, lambda=x, fitfun=cssLasso), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) # Test other input format alt_input <- list("subsample"=2:5, "feats_to_keep"=c(FALSE, rep(TRUE, 4), rep(FALSE, 2), TRUE)) output2 <- cssLoop(input=alt_input, x=x, y=y, lambda=0.08, fitfun=cssLasso) testthat::expect_true(is.integer(output2)) testthat::expect_equal(length(output2), length(unique(output2))) testthat::expect_true(length(output2) <= 8) testthat::expect_true(all(output2 %in% c(2, 3, 4, 5, 8))) testthat::expect_error(cssLoop(input= list("subsample"=2:5, "feats_to_keep"=c(FALSE, rep(TRUE, 4), rep(FALSE, 2))), x=x, y=y, lambda=0.08, fitfun=cssLasso), "length(feats_to_keep) == p is not TRUE", fixed=TRUE) # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) and nonsense y testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } testthat::expect_true(is.integer(cssLoop(input=1L:4L, x=x, y=y, lambda=TRUE, fitfun=testFitfun))) testthat::expect_true(is.integer(cssLoop(input=1L:4L, x=x, y=character(9), lambda=.05, fitfun=testFitfun))) }) ## Test passed with 16 successes. cssLoop() must validate the raw fitfun return against its documented contract before remapping to original feature indices, so that natural contract violations error loudly instead of silently corrupting the selection matrix (#151): testthat::test_that("cssLoop validates the raw fitfun return before remapping (#151)", { set.seed(1) n <- 40 p <- 6 x <- matrix(stats::rnorm(n * p), n, p) y <- stats::rnorm(n) subsample <- as.integer(1:(n %/% 2)) feats_to_keep <- c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE) # p_sub = 4 input <- list(subsample = subsample, feats_to_keep = feats_to_keep) mk <- function(val) function(X, y, lambda) val # fitfun returning a fixed value # Each invalid raw return must error (was silently wrong on main #151): testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(-1L))) # non-positive testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(c(TRUE, FALSE))), # logical "logical vector", fixed = TRUE) testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(1.5))) # fractional testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(NULL)), # NULL "NULL", fixed = TRUE) # 5 > p_sub = 4; on main this errors but MIS-reports "NA values" (post-remap # NA). Asserting the message makes this a real regression test AND locks in # the cosmetic fix. testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(5L)), "index greater than ncol(X)", fixed = TRUE) # Valid raw returns still work and remap correctly: testthat::expect_equal( cssLoop(input, x, y, lambda = 0.1, fitfun = mk(integer(0))), # select nothing integer(0)) testthat::expect_equal( cssLoop(input, x, y, lambda = 0.1, fitfun = mk(c(1L, 3L))), # raw cols 1,3 ... as.integer(which(feats_to_keep)[c(1L, 3L)])) # ... remap to 1,4 }) ## Test passed with 7 successes. Tests for checkGetClusterSelMatrixInput(): testthat::test_that("checkGetClusterSelMatrixInput works", { good_clusters <- list(happy=1L:8L, sad=9L:10L, med=11L) res <- matrix(sample(c(0, 1), size=6*11, replace=TRUE), nrow=6, ncol=11) testthat::expect_null(checkGetClusterSelMatrixInput(good_clusters, res)) testthat::expect_error(checkGetClusterSelMatrixInput(list(happy=1L:8L, med=11L), res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, 1:9), "is.matrix(res) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, res + .3), "all(res %in% c(0, 1)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, res[, 1:9]), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(1L:10L, res), "is.list(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=integer()), res), "all(lengths(clusters) >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=as.integer(NA)), res), "all(!is.na(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c2=6L:8L), res), "n_clusters == length(unique(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=14L), res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) }) ## Test passed with 10 successes. Tests for createSubsamples(): testthat::test_that("createSubsamples returns properly-named elements with feature removal (#69)", { set.seed(692) res <- createSubsamples(n = 30, p = 8, B = 5, sampling_type = "SS", prop_feats_remove = 0.3) testthat::expect_equal(length(res), 2L * 5L) # SS -> 2B elements # Every element is a named list(subsample, feats_to_keep) -- the invariant the # (now-meaningful) output stopifnot guards. testthat::expect_true(all(vapply(res, function(s) identical(names(s), c("subsample", "feats_to_keep")), logical(1)))) }) testthat::test_that("createSubsamples copies feats_to_keep onto each SS complementary pair (#128)", { set.seed(128) res <- createSubsamples(n = 30, p = 20, B = 5, sampling_type = "SS", prop_feats_remove = 0.5) # SS with feature removal -> 2B elements. testthat::expect_equal(length(res), 10L) # Each complementary pair (i, B + i) must share the SAME feats_to_keep -- the # Shah-Samworth pairing guarantee (createSubsamples copies subsample i's mask # onto its pair B + i). With p = 20, two independent rbinom draws would match # with probability ~2^-20 (~1e-6), so the identity below genuinely exercises # the copy rather than passing by coincidence. Every subsample must also retain # >= 2 features (the while-loop guarantee). for(i in 1:5){ testthat::expect_identical(res[[5L + i]]$feats_to_keep, res[[i]]$feats_to_keep) testthat::expect_gte(sum(res[[i]]$feats_to_keep), 2) testthat::expect_gte(sum(res[[5L + i]]$feats_to_keep), 2) } }) testthat::test_that("createSubsamples works", { res <- createSubsamples(n=20L, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 2*11) testthat::expect_true(all(lengths(res) == 20/2)) testthat::expect_equal(length(unique(res[[13]])), 20/2) set <- res[[4]] comp_set <- res[[4 + 11]] testthat::expect_equal(length(intersect(set, comp_set)), 0) testthat::expect_equal(length(union(set, comp_set)), length(c(set, comp_set))) testthat::expect_equal(20, length(c(set, comp_set))) # Try odd n res_odd <- createSubsamples(n=19L, p=23L, B=13L, sampling_type="SS", prop_feats_remove=0) testthat::expect_true(is.list(res_odd)) testthat::expect_equal(length(res_odd), 2*13) testthat::expect_true(all(lengths(res_odd) == floor(19/2))) testthat::expect_equal(length(unique(res_odd[[3]])), floor(19/2)) set_odd <- res_odd[[2]] comp_set_odd <- res_odd[[2 + 13]] testthat::expect_equal(length(intersect(set_odd, comp_set_odd)), 0) testthat::expect_equal(length(union(set_odd, comp_set_odd)), length(c(set_odd, comp_set_odd))) testthat::expect_equal(19 - 1, length(c(set_odd, comp_set_odd))) testthat::expect_error(createSubsamples(n=20L, p=5L, B=11L, sampling_type="MB", prop_feats_remove=0), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # misspecified sampling_type (not specifying error because contains quotation # marks) testthat::expect_error(createSubsamples(n=20L, p=5L, B=11L, sampling_type="S", prop_feats_remove=0)) testthat::expect_error(createSubsamples(n=11.1, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0), "n == round(n) is not TRUE", fixed=TRUE) testthat::expect_error(createSubsamples(n=-20L, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0), "n > 0 is not TRUE", fixed=TRUE) testthat::expect_error(createSubsamples(n=20L, p=5L, B=25.6, sampling_type="SS", prop_feats_remove=0), "length(subsamples) == B is not TRUE", fixed=TRUE) }) ## Test passed with 2 successes. ## Test passed with 16 successes. ## Test passed with 19 successes. Tests for getSubsamps(): testthat::test_that("getSubsamps works", { res <- getSubsamps(n=18L, B=21L, sampling_type="SS") testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 2*21) testthat::expect_true(all(lengths(res) == 18/2)) testthat::expect_equal(length(unique(res[[7]])), 18/2) set <- res[[3]] comp_set <- res[[3 + 21]] testthat::expect_equal(length(intersect(set, comp_set)), 0) testthat::expect_equal(length(union(set, comp_set)), length(c(set, comp_set))) testthat::expect_equal(18, length(c(set, comp_set))) }) ## Test passed with 7 successes. Tests for getSelMatrix(): testthat::test_that("getSelMatrix works", { set.seed(98623) x <- matrix(stats::rnorm(25*6), nrow=25, ncol=6) y <- stats::rnorm(25) subsamps_object <- createSubsamples(n=25, p=6, B=12, sampling_type="SS", prop_feats_remove=0) res <- getSelMatrix(x=x, y=y, lambda=0.01, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso) testthat::expect_true(is.matrix(res)) testthat::expect_equal(nrow(res), 2*12) testthat::expect_equal(ncol(res), 6) testthat::expect_true(all(res %in% c(0, 1))) testthat::expect_true(all(is.integer(res))) # Try a different fitfun testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } # Note that value of lambda doesn't matter res2 <- getSelMatrix(x=x, y=y, lambda="foo", B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=testFitfun) testthat::expect_true(is.matrix(res2)) testthat::expect_equal(nrow(res2), 2*12) testthat::expect_equal(ncol(res2), 6) testthat::expect_true(all(res2 %in% c(0, 1))) testthat::expect_true(all(is.integer(res2))) # With the per-subsample tryCatch (#155a), cssLoop's is.integer(subsample) # failure is caught and tagged, so the length(res_list) == nrow(res) check # (res_list length 1 vs 24 rows) now trips first. testthat::expect_error(getSelMatrix(x=x, y=y, lambda="0.02", B=12, sampling_type="SS", subsamps_object="subsamps_object", num_cores=1, fitfun=testFitfun), "length(res_list) == nrow(res) is not TRUE", fixed=TRUE) testthat::expect_error(getSelMatrix(x=x[1:8, ], y=y, lambda="foo", B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=testFitfun), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(getSelMatrix(x=x, y=y, lambda=-0.02, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) # Wrong B testthat::expect_error(getSelMatrix(x=x, y=y, lambda=0.02, B=37, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "length(res_list) == nrow(res) is not TRUE", fixed=TRUE) }) ## Test passed with 14 successes. A killed parallel worker makes parallel::mclapply() return NULL for that subsample. That NULL is distinct from a legitimate integer(0) (“selected nothing”) result, so getSelMatrix() must error rather than silently record a zero row (which would bias the selection proportions) (#104, L8): testthat::test_that("getSelMatrix detects a killed parallel worker (#104)", { set.seed(98623) x <- matrix(stats::rnorm(25*6), nrow=25, ncol=6) y <- stats::rnorm(25) subsamps_object <- createSubsamples(n=25, p=6, B=12, sampling_type="SS", prop_feats_remove=0) # Simulate a worker that was killed: mclapply returns a list containing NULL. testthat::local_mocked_bindings( mclapply = function(...) list(NULL), .package = "parallel") testthat::expect_error( getSelMatrix(x=x, y=y, lambda=0.01, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "parallel worker failed") }) ## Test passed with 1 success. We test the num_cores > 1 robustness fixes (issue #155). First (#155a), a fitfun failure is reported against its true subsample index rather than a prescheduling-misattributed one. fitfunFailureMessage() reads the tagged index carried by the cssr_loop_error, ignoring the (fallback) loop index it is passed: testthat::test_that("fitfunFailureMessage reads the tagged subsample index (#155a)", { msg <- fitfunFailureMessage( structure(list(i=7L, msg="boom"), class="cssr_loop_error"), 999L) testthat::expect_true(grepl("subsample 7", msg, fixed=TRUE)) testthat::expect_true(grepl("boom", msg, fixed=TRUE)) testthat::expect_false(grepl("subsample 999", msg, fixed=TRUE)) }) ## Test passed with 3 successes. End-to-end (#155a), when a fitfun fails on exactly one subsample under num_cores = 2, getSelMatrix() must name that subsample – not the successful subsample 1 it shares a preschedule chunk with. (Needs real forking, so the parallel call is probed and the test is skipped where forking is unavailable.) testthat::test_that("a parallel fitfun failure reports the true subsample (#155a)", { B <- 7L K <- 5L # in 2..B: shares preschedule chunk 1 with the SUCCESSFUL subsample 1 n <- 25L p <- 6L set.seed(408) x <- matrix(stats::rnorm(n * p), nrow=n, ncol=p) x[1, 1] <- -999 # sentinel "poison" marker in row 1 y <- stats::rnorm(n) # floor(n/2) = 12 distinct row indices per subsample; ONLY subsample K holds row 1. half <- floor(n / 2) subsamps_object <- lapply(seq_len(2L * B), function(j) if(j == K) 1:half else 2:(half + 1L)) # fitfun stops iff its subsample contains the poison row (row 1), else selects. poison_fitfun <- function(X, y, lambda){ if(any(X[, 1] == -999)) stop("poison") else c(1L, 2L) } # Probe real forking; skip (rather than fail) where unavailable. forked <- tryCatch({ parallel::mclapply(1:2, function(i) i, mc.cores=2L) TRUE }, error=function(e) FALSE) if(!forked){ testthat::skip("parallel forking unavailable in this environment") } err <- tryCatch( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=2L, fitfun=poison_fitfun), error=function(e) conditionMessage(e)) testthat::expect_true(grepl("subsample 5", err, fixed=TRUE)) testthat::expect_false(grepl("subsample 1", err, fixed=TRUE)) }) ## Test passed with 2 successes. And (#155b), fitfun warnings emitted inside forked workers must surface in the parent – the same count and messages as a serial run, rather than being silently swallowed: testthat::test_that("fitfun warnings surface under num_cores > 1 (#155b)", { B <- 6L n <- 25L p <- 6L set.seed(511) x <- matrix(stats::rnorm(n * p), nrow=n, ncol=p) y <- stats::rnorm(n) subsamps_object <- createSubsamples(n=n, p=p, B=B, sampling_type="SS", prop_feats_remove=0) # One warning per fitfun call; returns a valid selection. warn_fitfun <- function(X, y, lambda){ warning("wfit"); c(1L, 2L) } serial_warns <- testthat::capture_warnings( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1L, fitfun=warn_fitfun)) # one warning per subsample = 2*B testthat::expect_equal(sum(serial_warns == "wfit"), 2L * B) # Probe real forking; skip where unavailable. forked <- tryCatch({ parallel::mclapply(1:2, function(i) i, mc.cores=2L) TRUE }, error=function(e) FALSE) if(!forked){ testthat::skip("parallel forking unavailable in this environment") } par_warns <- testthat::capture_warnings( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=2L, fitfun=warn_fitfun)) # parallel no longer swallows them: same count AND same messages as serial. testthat::expect_equal(sum(par_warns == "wfit"), 2L * B) testthat::expect_identical(sort(par_warns), sort(serial_warns)) }) ## Test passed with 3 successes. Tests for cssLasso(): testthat::test_that("cssLasso works", { set.seed(24509) x <- matrix(stats::rnorm(15*4), nrow=15, ncol=4) y <- stats::rnorm(15) res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_true(is.integer(res)) testthat::expect_true(length(res) <= 4) testthat::expect_true(length(res) >= 0) # A no-duplicates assertion used to belong here, and #188 removed it rather # than leaving it in place looking like coverage. cssLasso() now ends in # sort(unique(unlist(pred))), so it de-duplicates its own return value and no # such assertion made here can fail for any input -- it would be a guardrail # blinded by the very change it appears to guard. The property still holds, # for a structural reason upstream: nonzeroCoef() builds each slot as which[x], # a logical subset of distinct column indices, so duplicates never arise. testthat::expect_true(all(res <= 4)) testthat::expect_true(all(res >= 1)) testthat::expect_error(cssLasso(X=x[1:13, ], y=y, lambda=0.01), "For method cssLasso, y must be a vector of length equal to nrow(X).", fixed=TRUE) testthat::expect_error(cssLasso(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) }) ## Test passed with 7 successes. predict.glmnet(type = \"nonzero\") does not return a stable container across glmnet versions, so cssLasso() must not care which one it gets. For the scalar s used here, glmnet 4.x returns a data.frame on a non-empty selection and a list on an empty one; glmnet 5.0 always returns a list. That is a consequence of the general rule, not the rule itself – 4.x coerces to a data.frame whenever apply() could simplify, which for one s value means whenever anything was selected. The clusterLassoCore() blocks further below cover the no-s case, where the same rule produces two different data.frame layouts (#190). These blocks mock glmnet::predict.glmnet to hand cssLasso() each shape directly, which pins the contract on any machine regardless of which glmnet is installed – the point being that a test exercising only the installed version pins nothing about the other one. The first block is the regression test for #188 proper: it fails on the pre-fix source at stopifnot(is.data.frame(pred)). The other two are pins rather than red-green tests – they pass on the pre-fix source too, and exist to hold the empty-selection and 4.x contracts against this refactor. testthat::test_that("cssLasso handles glmnet 5.0's list return shape (#188)", { set.seed(3011) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # glmnet >= 5.0 always returns a list, one slot per s value. Deliberately # UNSORTED so the assertion also pins the sort(); an already-ordered fixture # would pass whether or not the sort survived. testthat::local_mocked_bindings( predict.glmnet = function(...) list(c(4L, 1L, 3L)), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_identical(res, c(1L, 3L, 4L)) testthat::expect_true(is.integer(res)) }) testthat::test_that("cssLasso still handles glmnet 4.x's data.frame return shape (#188)", { set.seed(3012) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # glmnet 4.x's shape for a scalar s on a non-empty selection. The fix must be # bidirectional, not a swap of one hard-coded container for another. testthat::local_mocked_bindings( predict.glmnet = function(...) data.frame(X1 = c(4L, 1L, 3L)), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_identical(res, c(1L, 3L, 4L)) testthat::expect_true(is.integer(res)) }) testthat::test_that("cssLasso returns an empty selection under either glmnet shape (#188)", { set.seed(3013) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # Both 4.x and 5.0 signal "nothing selected" as a list holding NULL, so # unlist() gives length 0. This is the contract the container-independent # guard replaced an is.null(pred[[1]]) test to preserve. testthat::local_mocked_bindings( predict.glmnet = function(...) list(NULL), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=1e6) testthat::expect_identical(res, integer(0)) testthat::expect_true(is.integer(res)) }) ## Test passed with 2 successes. ## Test passed with 2 successes. ## Test passed with 2 successes. The blocks that follow cover the anchored-grid rewrite of cssLasso() (#125), which replaced predict.glmnet(exact = TRUE)’s internal full-path refit with a second glmnet() fit over the short grid anchoredLambdaGrid() builds. They divide the work deliberately, and the division is the thing to understand before changing any of them: the first block pins the output against the reference the rewrite replaced and passes on the pre-change source too; the second is the red-green regression test, and pins routing rather than construction; the third is what actually enforces the grid construction; and the fourth covers the on-grid short-circuit, which is a correctness requirement rather than a speed one. The degenerate-path block and the snapLambdaToGrid() blocks further down carry their own narratives. testthat::test_that("cssLasso is byte-identical to the exact refit (#125)", { # WHAT THIS PINS, since #199 narrowed it: cssLasso() is identical to the exact # refit EXCEPT where that refit's own interpolation produces sub-ULP debris. # Since #199, cssLasso() predicts at the penalty glmnet returned rather than at # the one it was asked for, so where the two differ in their last bits it reads # a solved column and the reference reads a blend of two -- and the blend can # carry a coefficient around 1e-17 that the solved column does not. # test_that("cssLasso returns a solved column rather than a blend (#199)") # pins where that divergence occurs. All four fixtures below round-trip # exactly, which is why none of them diverges and why their assertions did not # move. An inexact round trip is NOT on its own enough to redden this block: # measured over fixtures satisfying this block's own two rules, the large # majority of the inexact ones stay green, because a blend has to leak a # feature the reference does not already carry before the selected sets can # differ. # # A PIN, NOT A RED-GREEN TEST -- like the second and third #188 blocks above, # it passes on the pre-change source, because before the rewrite cssLasso() # *was* this reference. The block that fails on the pre-change source is # test_that("cssLasso fits the anchored grid rather than refitting exactly # (#125)"). The block that enforces the grid construction is # test_that("anchoredLambdaGrid holds its invariants (#125)"): this pin stays # entirely green under every simplification of that construction anyone has # tried -- dropping the re-appended anchor, dropping the head anchor, keeping # the prefix through kt, dropping the interior filter, naive truncation, and # removing the shortening altogether -- each of which reddens only the # invariants block. A green run here is not licence to simplify the helper. # # IF THIS BLOCK REDDENS, rule out a local change first -- most likely to # cssLasso()'s on-grid branch predicate, which reddens this block directly, or # to snapLambdaToGrid(), whose tolerance decides which penalties cssLasso() # treats as an exact grid hit and so which of them can still diverge here. A # change to anchoredLambdaGrid() reddens it only rarely: every mutation of the # helper tried during review left this block green, which is why the invariants # block below exists and why a green run here is not licence to simplify the # helper. Only once both are excluded does it mean glmnet has # changed one of the two internals the bit-identity rests on -- lambda.interp()'s # lambda[1] - lambda[k] normaliser, or the round trip a user-supplied lambda # grid makes through the response scale. That distinction matters because in # the litr weave this failure prints no test name and no assertion, arriving # instead as the missing-'./cssr' red herring, so this comment is the whole # diagnosis a reader gets. # # The reference MUST be built with do.call: exact=TRUE re-evaluates the fit's # stored call through update(), and a call that stored the symbol `alpha` # throws "object 'alpha' not found". That is why the production code used to # build its fit that way, and this is now the one place that still exercises # the fact. pin <- function(X, y, L, alpha){ ref_fit <- do.call(glmnet::glmnet, list(x=X, y=y, family="gaussian", alpha=alpha)) # Two fixture rules, asserted rather than written down, because a rule # nothing checks rots the first time someone adds a fixture. (i) L must sit # at least 1e-14 relative away from every fitted penalty: closer than that, # lambda.interp()'s approx() emits "collapsing to unique 'x' values" -- on # the current, the anchored and the naive-truncation paths alike, so it is # pre-existing rather than introduced here -- and importing it would move # the suite's WARN 0 baseline. (ii) the reference must select more than one # feature: an L above lambda_max clears rule (i) by orders of magnitude and # selects nothing, which reduces the identity assertion to # identical(integer(0), integer(0)) and makes it pass for the naive # truncation this change exists to avoid, and indeed for any implementation # at all. More than one rather than at least one because the naive grid's # breaks concentrate in *which* of several features moves. testthat::expect_gt(min(abs(L - ref_fit$lambda)/L), 1e-14) ref <- as.integer(sort(unique(unlist(glmnet::predict.glmnet(ref_fit, type="nonzero", s=L, exact=TRUE, x=X, y=y))))) testthat::expect_gt(length(ref), 1L) testthat::expect_identical(cssLasso(X=X, y=y, lambda=if(alpha == 1) L else c(lambda=L, alpha=alpha)), ref) } # Exactly four fixtures, spanning the regimes that matter -- and ADDING MORE # WOULD BUY NOTHING, which is the part worth knowing before anyone tries. This # pin compares selected sets, via type="nonzero", while the property at stake # is bit-identity of the coefficients. Measured: naive truncation breaks # bit-identity on roughly 2% of off-grid penalties yet reproduced the # reference's selected set in every one of 600 comparisons. So the limit is # GRANULARITY, not sample size, and the enforcer is the invariants block. Four # fixtures pin the regimes; a fortieth would pin nothing further. # (1) An ordinary iid design. set.seed(5011) n <- 60 p <- 25 X_iid <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y_iid <- as.numeric(X_iid %*% c(rep(1.5, 3), rep(0, p - 3)) + stats::rnorm(n)) pin(X_iid, y_iid, 0.164396, 1) # (2) A strongly correlated design, built the way the bundled-alpha block # above builds one. set.seed(5012) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y_corr <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) pin(Z, y_corr, 0.355123, 1) # (3) n < p, the regime cssr itself targets. set.seed(5013) n <- 40 p <- 120 X_np <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y_np <- as.numeric(X_np %*% c(rep(1.5, 4), rep(0, p - 4)) + stats::rnorm(n)) pin(X_np, y_np, 0.420866, 1) # (4) alpha bundled into lambda at a value other than 1, so the elastic-net # route is pinned too. pin(Z, y_corr, 0.887808, 0.4) }) ## Test passed with 12 successes. The regression test proper. It captures how cssLasso() calls predict.glmnet() and asserts that the call is no longer an exact refit and that the object handed over is the anchored fit: testthat::test_that("cssLasso fits the anchored grid rather than refitting exactly (#125)", { set.seed(5014) n <- 80 p <- 40 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 5), rep(0, p - 5)) + stats::rnorm(n)) # Off-grid and mid-path, so the truncation is substantial. L <- 0.153994 fA <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) seen <- NULL testthat::local_mocked_bindings( predict.glmnet = function(object, ..., exact=FALSE){ seen <<- list(exact=exact, k=length(object$lambda)) return(list(NULL)) }, .package="glmnet") # list(NULL) is the "nothing selected" shape, so cssLasso()'s own container # handling runs to completion and returns integer(0); the assertions are about # the call it made, not the value it returned. invisible(cssLasso(X=X, y=y, lambda=L)) # WHAT THE SECOND ASSERTION PINS: routing -- that cssLasso() handed # predict.glmnet() the anchored fit and not the full default path. It does NOT # pin what the grid contains, and naming anchoredLambdaGrid() inside it makes # it look as though it does. Production and the assertion call the same # helper, so a wrong construction moves both sides together and leaves this # block green; every helper mutant named in # test_that("anchoredLambdaGrid holds its invariants (#125)") passes here. That # block is what catches those. # # The form is expect_identical against the helper's own length rather than # expect_lt(seen$k, length(fA$lambda)), which is red pre-change too but is # coupled to the interior-padding constant: raising n_interior far enough # would redden a test whose message points at the wrong thing, even though # n_interior is a speed knob that cannot change any result. testthat::expect_false(isTRUE(seen$exact)) testthat::expect_identical(seen$k, length(anchoredLambdaGrid(fA$lambda, L))) }) ## Test passed with 2 successes. The invariants of anchoredLambdaGrid() itself, which is the block that enforces the grid construction. It calls the helper directly rather than mocking it: mocking a cssr-internal binding does not work in the bare weave, and there is nothing to gain from it here anyway. testthat::test_that("anchoredLambdaGrid holds its invariants (#125)", { # THE THREE MUTANTS THIS BLOCK EXISTS TO CATCH, and the assertion family that # catches each -- all three are natural "simplifications" a future reader may # try, and none of them is caught by # test_that("cssLasso is byte-identical to the exact refit (#125)"): # # dropping the re-appended final anchor -> the last-element assertion # keeping the prefix through kt, not kt + 1 -> the prefix assertion # dropping the mid[mid < hi & mid > lo] filter -> the strictly-decreasing # and no-duplicates pair # # DO NOT claim this block catches a change to the interior *spacing* rule # (geometric to arithmetic). Nothing catches it and nothing should: the # coefficients at s depend only on the grid's two endpoints and the retained # prefix, so the spacing of the filler is a pure speed choice. # # THE ULP-SPACED FIXTURE AT THE BOTTOM IS MANDATORY, and it is the reason the # strictly-decreasing and no-duplicates pair is worth asserting at all. # Without it those two cannot fail: on every other fixture here the shipped # construction is well-formed by construction, and on the guard branch the # helper returns unique(c(keep, lo)), which makes a no-duplicates assertion a # guardrail blinded by its own input -- the same shape #188 removed from the # "cssLasso works" block above rather than leave it looking like coverage. # Every fixture below whose kept prefix already reaches the end of the # augmented grid takes that branch, and so does the n_interior = 0 one. On a # path whose entries are a few ULPs apart the pair becomes live, because that # is where dropping the filter lets an interior point land on an anchor. All # three of the fixture's parts are load-bearing: a fixed vector rather than a # random draw (with an unseeded draw the detection is a coin flip), an # interior s rather than one below the path or at 0 (those take the guard # branch), and n_interior at the production 5, passed explicitly here rather # than taken from the default. Measured, the detection threshold is 5 and not # 2: below it the interior points are too sparse to land on an anchor and the # pair goes blind again. # `shortens` pins THE POINT OF THE CHANGE, which the five invariants below do # not: g_full satisfies every one of them, because it IS the reference grid. # Measured -- replacing this helper's body with return(g_full), i.e. removing # the optimisation outright, left the whole suite byte-identical at # [ FAIL 0 | WARN 0 | SKIP 0 | PASS 4262 ] before this argument existed. The # routing block cannot cover the gap either: it compares the fitted grid's # length against a call to this same helper, so a helper that stopped # shortening would move both sides of that comparison together. Both # directions are pinned, because returning the FULL grid is the correct # answer on the guard branch and is worth asserting rather than tolerating. inv <- function(lambda_path, s, n_interior=5L, shortens){ g <- anchoredLambdaGrid(lambda_path, s, n_interior) g_full <- unique(rev(sort(c(s, lambda_path)))) k_full <- length(g_full) m <- min(k_full, sum(g_full >= s) + 1L) # First and last elements identical to the augmented grid's, which is what # lambda.interp()'s lambda[1] - lambda[k] normaliser reads. testthat::expect_identical(g[1], g_full[1]) testthat::expect_identical(g[length(g)], g_full[k_full]) # Well-formed as a glmnet lambda argument. testthat::expect_true(all(diff(g) < 0)) testthat::expect_identical(length(unique(g)), length(g)) # The prefix through one element past s is carried over untouched. testthat::expect_identical(g[1:m], g_full[1:m]) # And the grid is actually shorter than the one exact=TRUE would have refit # over -- or exactly it, on the guard branch, where there is nothing to drop. if(shortens){ testthat::expect_lt(length(g), k_full) } else{ testthat::expect_identical(length(g), k_full) } } # A synthetic decreasing path, in the geometric shape glmnet's default grid # has. No RNG and no fit: this block is about the construction, not about # glmnet. lp <- exp(seq(log(2), log(0.01), length.out=30)) inv(lp, 5, shortens=TRUE) # s above the largest penalty inv(lp, 0.001, shortens=FALSE) # s below the smallest: guard branch inv(lp, lp[9], shortens=TRUE) # s exactly on the path inv(lp, 0, shortens=FALSE) # s = 0: guard branch inv(lp, sqrt(lp[9]*lp[10]), shortens=TRUE) # mid-path, the production case inv(lp, sqrt(lp[9]*lp[10]), 0L, shortens=TRUE) # no interior padding inv(0.5, 0.1, shortens=FALSE) # length-1 path, s below it inv(0.5, 5, shortens=FALSE) # length-1 path, s above it inv(0.5, 0.5, shortens=FALSE) # length-1 path, s equal to it # The ULP-spaced path: eight distinct, strictly decreasing doubles a few # units in the last place apart, exercised at an on-grid s and at the # production n_interior. lp_ulp <- 1 + (8:1) * .Machine$double.eps inv(lp_ulp, lp_ulp[4], 5L, shortens=FALSE) }) ## Test passed with 60 successes. Finally the on-grid short-circuit, which exists to keep the exported direct-call route byte-identical rather than to save a fit: testthat::test_that("cssLasso short-circuits when lambda is already on the path (#125)", { set.seed(5011) n <- 60 p <- 25 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 3), rep(0, p - 3)) + stats::rnorm(n)) # do.call here is habit rather than necessity -- alpha is a literal, and this # block's s values are all ON the fitted grid, so predict.glmnet(exact=TRUE) # returns without ever reaching update(). The identity block's claim to be the # one place that still exercises the stored-call fact is therefore accurate. fA <- do.call(glmnet::glmnet, list(x=X, y=y, family="gaussian", alpha=1)) # Rank 1 is in the fixture set deliberately: when the short-circuit is # deleted, the resulting selected-set breaks concentrate at the top of the # path. on_grid <- fA$lambda[c(1, 12)] for(L in on_grid){ ref <- as.integer(sort(unique(unlist(glmnet::predict.glmnet(fA, type="nonzero", s=L, exact=TRUE, x=X, y=y))))) testthat::expect_identical(cssLasso(X=X, y=y, lambda=L), ref) } # The mock is installed here rather than at the top of the block because it # would otherwise replace the predict.glmnet() that computes the reference # above; local_mocked_bindings() takes effect from this line to the end of the # block. # # This assertion and the identity assertions above are BOTH live, and an # earlier revision of this comment claimed the identity ones were not. # Measured against a [ FAIL 0 | PASS 4262 ] control, deleting the short-circuit # reddens three of this block's assertions, the rank-1 identity comparison # among them -- which is precisely why the comment above puts rank 1 in the # fixture set, and the two statements contradicted each other until now. What # this assertion adds is a cause rather than a symptom: it names the fit handed # to predict.glmnet(), so with the short-circuit the default path arrives # untouched and without it a second, shorter fit does. Do not trim the rank-1 # fixture as redundant -- it is the only value-level detector for this route. seen <- NULL testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ seen <<- length(object$lambda) return(list(NULL)) }, .package="glmnet") for(L in on_grid){ invisible(cssLasso(X=X, y=y, lambda=L)) testthat::expect_identical(seen, length(fA$lambda)) } }) ## Test passed with 4 successes. anchoredLambdaGrid()’s guard branch has a reason that is easy to mistake for a hypothetical: a perfectly orthogonal design makes glmnet() return a $lambda of NaN followed by zeros, and the guard is what keeps log(0) out of the interior-point construction on such a path. The next block pins that end to end, and in particular pins the decision not to validate $lambda at runtime: a positivity check on it would turn this case from an empty selection into an error, on exactly the shape issue #157 was filed to stop crashing. testthat::test_that("cssLasso survives a degenerate lasso path (#125)", { # A design with max|X'y| EXACTLY zero -- paired +1/-1 integer rows, the #157 # construction. Not merely orthogonal and not numerically small: measured, an # orthonormal X with a generic y gives an ordinary path, and so does one with # max|X'y| at 1e-16. Only exact zero degenerates the path. y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1)) X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0), c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1)) storage.mode(X) <- "double" testthat::expect_identical(max(abs(crossprod(X, y))), 0) # The path really is degenerate. These two assertions are the upstream-drift # detector: if a future glmnet stops returning NaN-then-zeros here, they fail # and the comment in anchoredLambdaGrid() about this case needs re-deriving. lam <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1)$lambda testthat::expect_true(anyNA(lam)) testthat::expect_true(any(lam == 0, na.rm=TRUE)) # And cssLasso() returns an empty selection rather than erroring. This is the # assertion that holds the no-runtime-validation decision: adding # stopifnot(all(lasso_model$lambda > 0)) -- or all(is.finite(.)), which also # fails here -- reddens this line. Use lambda strictly above 0; at exactly 0 # this design raises a PRE-EXISTING interpolation error on both this branch # and origin/main, which is not what this block is about. testthat::expect_identical(cssLasso(X=X, y=y, lambda=0.01), integer(0)) }) ## Test passed with 4 successes. The three blocks below cover the penalty snap (#199) – cssLasso() predicting at the entry glmnet reported rather than at the penalty it asked for. They divide the work as deliberately as the #125 blocks do: the first is the red-green regression test, and is the one criterion 5 names – though the third reddens under the same mutation too, so a reader scoring it should expect two assertions to move rather than one; the second pins the helper’s arithmetic against hand-built vectors, and owns the tolerance; the third drives the real cssLasso() end to end and asserts that what comes back is a solved lasso column’s nonzero set rather than a blend of two. testthat::test_that("cssLasso predicts at the penalty glmnet fitted (#199)", { # THE RED-GREEN TEST FOR #199, and the one acceptance criterion 5 names. It is # not the only block that reddens under the mutation -- measured, this block's # wiring assertion and the end-to-end block's structural assertion both go red # and nothing else in the suite moves. The # mutation to score is "helper present, call site absent": reverting the # source hunks outright deletes snapLambdaToGrid(), so # test_that("snapLambdaToGrid holds its invariants (#199)") fails with "could # not find function", which is the symbol's absence speaking rather than an # assertion observing behaviour. Only a block that drives cssLasso() sees the # wiring. Measured under that mutation: this block's wiring assertion and # test_that("cssLasso returns a solved column rather than a blend (#199)")'s # structural assertion are the only two things in the suite that redden. # # THE SAME MOCK AND THE SAME FIRING CONDITION LIVE IN # test_that("cssLasso returns a solved column rather than a blend (#199)"). # The nudge fires on !is.null(list(...)$lambda), which is a claim about how # cssLasso() spells its second glmnet() call, so a refactor of that call # disarms BOTH blocks at once rather than one of them. Change either mock and # check the other. (The negative control below is what makes such a # disarming visible here rather than silent.) # # The blend is reached by MOCKING rather than by a live fixture, because # glmnet echoes this fixture's grid back verbatim on this machine, so an # unmocked wiring assertion would be green before the change here. Mocking an # external package's binding is safe in the bare weave; mocking a cssr # internal is not, which is why the invariants block calls the helper # directly instead. set.seed(5014) n <- 80 p <- 40 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 5), rep(0, p - 5)) + stats::rnorm(n)) # FIXTURE CONSTRAINT, asserted rather than written down: L must be OFF the # first fit's own grid, so the refit route runs and the nudge below can # apply at all. An on-grid L short-circuits, the second glmnet() call never # happens, and the wiring assertion then reads TRUE wired and unwired alike. L <- 0.153994 m0 <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) testthat::expect_identical(match(L, m0$lambda, 0L), 0L) real_glmnet <- glmnet::glmnet # captured BEFORE local_mocked_bindings(), which # rebinds inside glmnet's namespace: glmnet::, glmnet::: and getFromNamespace() # inside a mock all resolve to the MOCK and recurse until R aborts with # "evaluation nested too deeply". # Measured, all three. In the weave that error is thrown from test_that() at # top level and arrives as the missing-'./cssr' red herring. seen_grid <- NULL seen_s <- NULL testthat::local_mocked_bindings( glmnet = function(...){ f <- real_glmnet(...) # The nudge is what the response-scale round trip does to a supplied # penalty, made deterministic. It applies only to the SECOND fit, whose # reported $lambda is the vector cssLasso() now reads; the condition is a # claim about how cssLasso() spells that call, which is why the negative # control below is not optional. The mock must delegate rather than # fabricate a fit, because cssLasso() runs stopifnot(all.equal(class(...))) # on the first one. # # THE CONSTANT IS 2*eps AND IS BOUNDED ON BOTH SIDES. What is multiplied # is glmnet's ECHO of L, not L: writing u for one ULP of L and m for its # significand, fl((L - u)*(1 + eps)) == L exactly whenever m < 1.5, and # this fixture's L = 0.153994 has m = 1.2320. So on a platform whose echo # sits an ULP below this machine's, a 1*eps nudge lands back on L, the # negative control below is red on correct code, and the wiring assertion # goes green with the wiring removed. Measured over 6e5 enumerated # (magnitude, echo) pairs inside glmnet's round-trip bound: 1*eps # collapses in about one in six, 2*eps in none, and 3*eps never collapses # but reaches an offset of 4.286 eps*L, outside the helper's n_ulp = 4. # More is not safer here. if(!is.null(list(...)$lambda)) f$lambda <- f$lambda*(1 + 2*.Machine$double.eps) f }, predict.glmnet = function(object, ..., s){ seen_grid <<- object$lambda seen_s <<- s return(list(NULL)) }, .package="glmnet") # list(NULL) is the "nothing selected" shape, so cssLasso()'s container # handling runs to completion; the assertions are about the call it made. invisible(cssLasso(X=X, y=y, lambda=L)) # THE INSTRUMENT'S OWN NEGATIVE CONTROL, and it is not optional: it says the # requested penalty is absent from the grid cssLasso() predicted from -- by # the nudge, by glmnet's natural round trip, or both. Without it the block has # two measured ways of passing while checking nothing. An on-grid L # short-circuits past the nudge, and this then reads L's own index in the # first fit's path rather than 0; and a mock whose firing condition stopped # matching how cssLasso() spells its second call nudges nothing, which reads # 27 on this fixture. It is 0 only in the state this block exists to test. testthat::expect_identical(match(L, seen_grid, 0L), 0L) # THE WIRING ASSERTION: the penalty handed to predict.glmnet() is an element # of the grid predicted from, which is exactly what makes lambda.interp() # report an exact hit. FALSE without the call site in cssLasso(), TRUE with it. testthat::expect_gt(match(seen_s, seen_grid, 0L), 0L) }) ## Test passed with 3 successes. The helper’s own arithmetic, pinned directly against hand-built vectors: testthat::test_that("snapLambdaToGrid holds its invariants (#199)", { # THIS BLOCK PINS THE ARITHMETIC, NOT THE WIRING, and it cannot pin the # wiring: reverting #199's source hunks deletes the function it calls, so it # would fail with "could not find function". The block that discharges the # red-green obligation is # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). # # The scalar precondition. This assertion is its only cover: measured before # it existed, deleting stopifnot(length(s) == 1L) from the helper reddened # nothing at all, so the guard could have been weakened later in silence. With # it, that deletion records an ERROR rather than a failure -- the mismatched # expect_error() re-raises and aborts this block, taking the assertions below # it with it, so read the error column and not just the summary line's FAIL, # which aggregates both. fixed = TRUE is mandatory: the message contains ( and # ), so it does not match itself as a regex (grepl(m, m) is FALSE), and at # edition 2 a mismatch aborts the whole render behind gotcha 1's # missing-directory error. testthat::expect_error(snapLambdaToGrid(c(1, 0.5), c(1, 0.5)), "length(s) == 1L is not TRUE", fixed=TRUE) # # TWO MUTANTS DELIBERATELY HAVE NO ASSERTION HERE, so that the next reader # does not add one. Replacing the tolerance comparison's <= with < is # undetectable, but NOT because nothing reaches the boundary -- the s = 0 # fixture below sits exactly on it, since |g - s| and the relative tolerance # are both 0 there. It is undetectable because on that boundary both branches # return the same double, so no observable differs. And a very large n_ulp is # harmless on cssLasso()'s ordinary route, because anchoredLambdaGrid() has # put s in the grid and which.min() therefore picks s's own echo whatever the # tolerance admits. eps <- .Machine$double.eps # One ULP below a grid entry, one ULP above, and an exact hit. The offsets are # built as g*(1 +- eps) rather than typed as literals so the fixture states # the property: the result is 1 to 2 ULP of g at any magnitude and can never # be zero for a normal double, so it is inside n_ulp = 4 by construction # rather than by measurement. g <- c(1.0, 0.5) testthat::expect_identical(snapLambdaToGrid(g, 1.0*(1 + eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 1.0*(1 - eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 1.0), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 0.5*(1 - eps)), 0.5) # THE ONLY FIXTURE THAT MAKES THE TOLERANCE'S * s SCALING LOAD-BEARING, and # its magnitude is the point of it. Measured: an absolute-tolerance mutant # (n_ulp*eps with the * s dropped) is INDISTINGUISHABLE from the correct # helper at magnitude 4, and first diverges at 6 -- on grid c(6, 3) the # correct helper returns 6 and the mutant returns 6.0000000000000018, and here # it returns 1000000.0000000002. Every other fixture in this block sits at # O(1), and cssLasso()'s penalty is on the response scale, so a user with a # larger response is exactly who the mutant silently stops snapping for. DO # NOT "simplify" this to a friendlier magnitude. testthat::expect_identical(snapLambdaToGrid(c(1e6, 5e5), 1e6*(1 + eps)), 1e6) # A penalty between two well-separated entries, ON BOTH SIDES. Both are needed # because dropping abs() from the tolerance comparison is a genuine one-sided # defect and only the below case catches it: measured on this grid, s = 0.7 # (nearest entry 0.5, below it) reddens that mutant while s = 0.8 (nearest # entry 1.0, above it) leaves it green. testthat::expect_identical(snapLambdaToGrid(g, 0.7), 0.7) testthat::expect_identical(snapLambdaToGrid(g, 0.8), 0.8) # A length-1 lambda_fitted, which has the same asymmetry: 0.9 is the case # that catches the dropped-abs() mutant. testthat::expect_identical(snapLambdaToGrid(0.5, 0.9), 0.9) testthat::expect_identical(snapLambdaToGrid(0.5, 0.1), 0.1) testthat::expect_identical(snapLambdaToGrid(0.5, 0.5*(1 + eps)), 0.5) # NaN mixed with numbers is the shape glmnet's FIRST fit returns on the # degenerate path test_that("cssLasso survives a degenerate lasso path # (#125)") drives, and which.min() simply ignores it. All-NaN and empty are # the two inputs that make which.min() return integer(0), where # if(logical(0)) would abort: they are what the length(j) == 1L clause is # for. NONE OF THE THREE IS REACHABLE THROUGH cssLasso() TODAY -- measured, # anchoredLambdaGrid() drops the NaN, so even on that degenerate design the # vector arriving here is c(0.01, 0) -- but the helper is stated to survive # them, so it must. testthat::expect_identical(snapLambdaToGrid(c(NaN, 1.0, 0.5), 1.0*(1 + eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(c(NaN, NaN), 0.3), 0.3) testthat::expect_identical(snapLambdaToGrid(numeric(0), 0.3), 0.3) # s = 0 is permitted by checkCssLassoInputs(), and there the relative # tolerance collapses to exactly zero, so only an exact zero in lambda_fitted # can match. Both grids therefore return 0 and the pair cannot be told apart # by value -- one returns the grid's own zero and the other returns s. What it # pins is that neither path errors and neither drifts off zero. testthat::expect_identical(snapLambdaToGrid(c(1.0, 0.5, 0), 0), 0) testthat::expect_identical(snapLambdaToGrid(c(1.0, 0.5), 0), 0) }) ## Test passed with 16 successes. And the end-to-end effect: the coefficient vector cssLasso() reads back is a solved lasso path column, so its non-selected entries are exact zeros rather than a blend’s residue. testthat::test_that("cssLasso returns a solved column rather than a blend (#199)", { # WHAT THIS BLOCK DOES AND DOES NOT COVER, stated the way the #125 blocks # state their division of labour, because a future reader who trims something # on the strength of three green blocks is the failure mode. # # - j below is a DELIBERATE SECOND COPY of the argmin, hard-coded rather than # a call to snapLambdaToGrid(). That is why a production change to the # argmin -- which.max, a dropped abs(), an off-by-one -- moves the result # without moving the reference and is caught here. DO NOT "de-duplicate" it # into a helper call; doing so is exactly what blinds this block. # - It CANNOT see a tolerance that is too permissive, by construction: the # reference is the nonzero set of the column nearest L, which is what a # helper with no tolerance at all produces, so every mutant that widens the # tolerance moves both sides together. The invariants block owns tolerance. # - It does not rebuild the anchored grid, so it is not coupled to production # through anchoredLambdaGrid(). It IS blind to a change in which fit is # routed to predict.glmnet(), since it reads its reference off the very # object cssLasso() chose -- and that has independent cover: measured, # making cssLasso() never refit reddens # test_that("cssLasso is byte-identical to the exact refit (#125)"), # test_that("cssLasso fits the anchored grid rather than refitting exactly # (#125)"), test_that("cssLasso survives a degenerate lasso path (#125)") # and test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). # Four blocks, so do not trim one of them believing this block covers it. # - It shares its mock, and the mock's firing condition, with # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). That # condition is a claim about how cssLasso() spells its second glmnet() # call, so a refactor of that call disarms BOTH blocks at once. Change # either mock and check the other. # - The one residual coupling, named rather than denied: the assertion embeds # the same belief the helper embeds, that the right column is the argmin of # |grid - L|. If that belief were wrong, both would move together. That is # inherent to a structural assertion of this shape. set.seed(2019) n <- 40 p <- 30 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 4), rep(0, p - 4)) + stats::rnorm(n)) # Off the first fit's grid, so the refit route runs, and near the top of the # path, where a blend is most likely: lambda.interp() forms (lambda[1] - s) # over the normaliser (lambda[1] - lambda[k]), and the numerator's subtraction # absorbs more of an ULP-scale perturbation of s the further s sits below # lambda[1]. It is a gradient and NOT a threshold -- measured, blends occur # down to L/lambda[1] near 0.05 -- so this fixture is chosen to make the blend # reliable here, not because a lower one could not blend. L <- 1.6415147022263146 m0 <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) testthat::expect_identical(match(L, m0$lambda, 0L), 0L) real_glmnet <- glmnet::glmnet # captured BEFORE local_mocked_bindings() -- real_pred <- glmnet::predict.glmnet # `glmnet::` inside a mock reaches the MOCK seen_fit <- NULL testthat::local_mocked_bindings( glmnet = function(...){ f <- real_glmnet(...) if(!is.null(list(...)$lambda)) f$lambda <- f$lambda*(1 + 2*.Machine$double.eps) f }, predict.glmnet = function(object, ...){ seen_fit <<- object real_pred(object, ...) }, .package="glmnet") got <- cssLasso(X=X, y=y, lambda=L) # THE PERTURBATION IS SYNTHETIC ON PURPOSE. Driving the fixture's own natural # round trip would put a platform-dependent assertion inside a gating CI # matrix: fl(fl(s/ys)*ys) is exact for about 90% of random pairs and this # fixture is in the inexact 10%, so an ULP move in the response scale -- which # glmnet computes in Fortran, where -ffp-contract=fast permits FMA -- redraws # it with roughly a nine-in-ten chance of becoming exact. The constant is # 2*eps for the reason the routing block's comment gives. The cost, recorded # rather than hidden: no gating assertion anywhere exercises glmnet's natural # round trip. Note also that seen_fit is not an object glmnet ever produced -- # it carries a synthetic $lambda and a real $beta, and the assertion reads the # real half. # # The anti-vacuity guard, and it is about the fit cssLasso() actually # predicted from, which is why that fit is captured rather than rebuilt: the # requested penalty is absent from that grid, by the nudge, by the natural # round trip, or both. What the guard is FOR is the platform where neither # holds: there L would be in the grid, frac would be exactly 1, and the block # would return the same answer before and after the change, so the guard # reddens instead of passing vacuously. It cannot, however, detect the nudge # alone going away -- measured on this machine, with both nudges disarmed the # guard still reads 0 and the block still separates 1 3 4 from 1 4, because # this fixture's natural round trip is already inexact here. testthat::expect_identical(match(L, seen_fit$lambda, 0L), 0L) j <- which.min(abs(seen_fit$lambda - L)) # unname() IS LOAD-BEARING, NOT TIDINESS: seen_fit$beta is a dgCMatrix whose # rownames glmnet sets to V1 ... Vp, so which() returns a NAMED integer vector # while cssLasso() returns an unnamed one, and the assertion without it is red # on correct code at both editions -- reporting a names diff, whose first # reading is "the snap did not work". testthat::expect_identical(got, unname(which(seen_fit$beta[, j] != 0))) }) ## Test passed with 3 successes. Tests for getClusterSelMatrix(): testthat::test_that("getClusterSelMatrix works", { good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L, blue_clust=9L) B <- 14 p <- 9 res_entries <- as.integer(sample(c(0, 1), size=2*B*p, replace=TRUE)) good_res <- matrix(res_entries, nrow=2*B, ncol=p) res <- getClusterSelMatrix(good_clusters, good_res) testthat::expect_true(is.matrix(res)) testthat::expect_equal(nrow(res), 2*B) # 3 clusters testthat::expect_equal(ncol(res), 3) testthat::expect_identical(colnames(res), c("red_cluster", "green_cluster", "blue_clust")) testthat::expect_true(all(is.integer(res))) testthat::expect_true(all(res %in% c(0, 1))) # (#105, L12) Value-pin EVERY cluster column (not just cluster 2): each column # must equal the "at least one member of that cluster was selected" indicator. # This pins the full feat2clus mapping/ordering that the #57 rowsum refactor # relies on, including the singleton cluster (drop=FALSE keeps it a matrix). for(j in seq_along(good_clusters)){ testthat::expect_equal(res[, j], as.integer(rowSums(good_res[, good_clusters[[j]], drop=FALSE]) > 0)) } # Single-cluster case (#57): t(clust_counts > 0L) collapses to one column res1 <- getClusterSelMatrix(list(only = 1L:9L), good_res) testthat::expect_equal(ncol(res1), 1) testthat::expect_true(all(is.integer(res1))) # Not all features in a cluster bad_clusters <- list(red_cluster=1L:5L, green_cluster=6L:7L, blue_clust=9L) testthat::expect_error(getClusterSelMatrix(bad_clusters, good_res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) bad_res_entries <- as.integer(sample(c(0, 1, 2), size=2*B*p, replace=TRUE)) bad_res <- matrix(bad_res_entries, nrow=2*B, ncol=p) testthat::expect_error(getClusterSelMatrix(good_clusters, bad_res), "all(res %in% c(0, 1)) is not TRUE", fixed=TRUE) }) ## Test passed with 13 successes. Finally, tests for css() itself! testthat::test_that("css works", { set.seed(8712) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L, c4=10:11) res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) # Basic output testthat::expect_true(is.list(res)) testthat::expect_identical(class(res), "cssr") testthat::expect_identical(names(res), c("feat_sel_mat", "clus_sel_mat", "X", "y", "clusters", "train_inds")) # feat_sel mat testthat::expect_true(is.integer(res$feat_sel_mat)) testthat::expect_true(is.matrix(res$feat_sel_mat)) testthat::expect_true(all(res$feat_sel_mat %in% c(0, 1))) testthat::expect_equal(ncol(res$feat_sel_mat), 11) testthat::expect_null(colnames(res$feat_sel_mat)) # clus_sel_mat testthat::expect_true(is.integer(res$clus_sel_mat)) testthat::expect_true(is.matrix(res$clus_sel_mat)) testthat::expect_true(all(res$clus_sel_mat %in% c(0, 1))) # 4 clusters testthat::expect_equal(ncol(res$clus_sel_mat), 4) testthat::expect_identical(colnames(res$clus_sel_mat), names(res$clusters)) testthat::expect_equal(length(colnames(res$clus_sel_mat)), 4) testthat::expect_equal(length(unique(colnames(res$clus_sel_mat))), 4) testthat::expect_true(all(!is.na(colnames(res$clus_sel_mat)))) testthat::expect_true(all(!is.null(colnames(res$clus_sel_mat)))) # X testthat::expect_true(is.matrix(res$X)) testthat::expect_true(all(!is.na(res$X))) testthat::expect_true(is.numeric(res$X)) testthat::expect_equal(ncol(res$X), 11) testthat::expect_equal(nrow(res$X), 15) # y testthat::expect_true(is.numeric(res$y)) testthat::expect_equal(length(res$y), 15) # clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), length(names(res$clusters))) testthat::expect_equal(length(res$clusters), length(unique(names(res$clusters)))) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) clust_feats <- integer() for(i in 1:length(res$clusters)){ clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:11))) # train_inds testthat::expect_identical(res$train_inds, integer()) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars res_fitfun <- css(X=X_df, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10) testthat::expect_identical(class(res_fitfun), "cssr") # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) res_fitfun <- css(X=df2, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10) testthat::expect_identical(class(res_fitfun), "cssr") # Should get error if I try to use clusters in this data.frame that contains # factors with more than two levels testthat::expect_error(css(X=df2, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10, clusters=1:3), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] res_names <- css(X=x2, y=y, lambda=0.01, clusters=good_clusters, B = 13) testthat::expect_identical(class(res_names), "cssr") testthat::expect_identical(colnames(x2), colnames(res_names$X)) testthat::expect_identical(colnames(x2), colnames(res_names$feat_sel_mat)) # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } res_fitfun <- css(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, B = 10, fitfun=testFitfun) testthat::expect_identical(class(res_fitfun), "cssr") # Bad lambda testthat::expect_error(css(X=x, y=y, lambda=-0.01, B = 10), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(css(X=x, y=y, lambda="foo", B = 10), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) # Single cluster res_sing_clust <- css(X=x, y=y, lambda=0.01, clusters=1:3, B = 10) testthat::expect_identical(class(res_sing_clust), "cssr") testthat::expect_equal(length(res_sing_clust$clusters), 11 - 3 + 1) testthat::expect_true(length(unique(names(res_sing_clust$clusters))) == 11 - 3 + 1) testthat::expect_true(all(!is.na(names(res_sing_clust$clusters)))) testthat::expect_true(all(!is.null(names(res_sing_clust$clusters)))) # No cluster testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10)), "cssr") # All clusters named testthat::expect_identical(class(css(X=x, y=y, clusters=list("a"=1:5, "b"=6:10, "c"=11), lambda=0.01, B=10)), "cssr") # Other sampling types testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type="MB"), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type="S")) testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type=1), "is.character(sampling_type) is not TRUE", fixed=TRUE) # B testthat::expect_warning(css(X=x, y=y, lambda=1, B=5), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_error(css(X=x, y=y, lambda=1, B=list(10)), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) # Clusters testthat::expect_error(css(X=x, y=y, lambda=1, clusters="red"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) # prop_feats_remove testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10, prop_feats_remove=0.3)), "cssr") # Weirdly high, but still valid, value of prop_feats_remove testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10, prop_feats_remove=0.9999999999)), "cssr") # Use train_inds argument res_train <- css(X=x, y=y, lambda=0.01, B = 10, train_inds=11:15) testthat::expect_equal(res_train$train_inds, 11:15) }) testthat::test_that("duplicate clusters are removed to match the docs (#156)", { set.seed(9156) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # (i) Unnamed duplicate cluster: css returns the same result as the # deduplicated input (css is stochastic, so seed both calls identically). set.seed(41) res_dup <- css(X=x, y=y, lambda=0.01, clusters=list(1:2, 1:2), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) set.seed(41) res_dedup <- css(X=x, y=y, lambda=0.01, clusters=list(1:2), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) testthat::expect_identical(res_dup, res_dedup) # (ii) First name wins, DIRECT helper path (checkFormatClustersInput, finding # 2): the length check now runs before the removal, so a named duplicate keeps # the first occurrence and its name. testthat::expect_identical( checkFormatClustersInput(list(a=2:3, b=2:3), p=10, clust_names=c("a", "b"), get_prototypes=FALSE, x=NA, y=NA, R=NA), list(a=2:3)) # (ii) First name wins, END-TO-END css path (checkCssInputs, finding 3): a # named duplicate runs without error and keeps the first occurrence's name. res_named <- css(X=x, y=y, lambda=0.01, clusters=list(myclust=2:3, dup=2:3), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) testthat::expect_true("myclust" %in% names(res_named$clusters)) testthat::expect_false("dup" %in% names(res_named$clusters)) # (iii) cssSelect and cssPredict route through css -> checkCssInputs, so they # inherit the fix: a named duplicate cluster runs without error. # # cssPredict() reports a max_num_clusts tie on this fixture on this machine, # because #199's penalty snap changed which features cssLasso() returns here # and dropped the modal cluster's selection proportion into a tie. The tie is # not asserted: whether it occurs depends on the estimated model size, and so # on glmnet's lasso path rather than on cssr. The warning itself keeps # deterministic coverage in "checkSelectedClusters works" and in # test_that("plot.cssr surfaces the tie-breach warning (#159c)"), and muffling # this one message by its text leaves every other warning in the block visible # (#186, #199). # # BOTH calls are wrapped although only cssPredict() ties today, because which # of them ties follows from that same lasso path, so a one-call muffle would # redden on a platform whose path differs slightly. The assertions below are # untouched -- they are about well-formedness of the returns, which the tie is # orthogonal to. sel <- withCallingHandlers( cssSelect(X=x, y=y, clusters=list(myclust=2:3, dup=2:3)), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) testthat::expect_identical(names(sel), c("selected_clusts", "selected_feats", "weights")) test_x <- matrix(stats::rnorm(5*11), nrow=5, ncol=11) preds <- withCallingHandlers( cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters=list(myclust=2:3, dup=2:3)), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) testthat::expect_true(is.numeric(preds)) testthat::expect_equal(length(preds), 5) }) testthat::test_that("css errors on an X containing NA (#74)", { set.seed(8642) X <- matrix(stats::rnorm(20 * 4), nrow = 20, ncol = 4) X[3, 2] <- NA y <- stats::rnorm(20) testthat::expect_error( css(X = X, y = y, lambda = 0.01), "must not contain missing", fixed = TRUE) }) ## Test passed with 57 successes. ## Test passed with 7 successes. ## Test passed with 1 success. The fitfun extension point accepts any function whose arguments are exactly X, y, and lambda – in any order, with or without defaults – because cssLoop calls fitfun by keyword (do.call(fitfun, list(X=..., y=..., lambda=...))). A wrong or extra argument set is rejected with a message listing the arguments actually detected (issue #154). testthat::test_that("css accepts any (X, y, lambda) fitfun signature and rejects wrong args (#154)", { set.seed(1) x <- matrix(stats::rnorm(60), 20, 3) y <- stats::rnorm(20) # (a) A default on lambda is accepted (rejected on the base by identical()). f_default <- function(X, y, lambda = 0.1) cssLasso(X, y, lambda) res_def <- css(x, y, lambda = 0.01, fitfun = f_default, B = 10) testthat::expect_identical(class(res_def), "cssr") # (b) Reordered args are accepted AND produce identical results # (cssLoop calls fitfun by keyword, so order is irrelevant). f_reordered <- function(y, X, lambda) cssLasso(X, y, lambda) set.seed(7); res_re <- css(x, y, lambda = 0.01, fitfun = f_reordered, B = 10) set.seed(7); res_ord <- css(x, y, lambda = 0.01, fitfun = cssLasso, B = 10) testthat::expect_equal(res_re$feat_sel_mat, res_ord$feat_sel_mat) # (c) A wrong argument set is rejected, with the message listing the ACTUAL args. testthat::expect_error( css(x, y, lambda = 0.01, fitfun = function(X, y, z) 1L, B = 5), "must accept exactly the arguments X, y, and lambda (in any order, with or without defaults). Detected arguments to fitfun: X, y, z", fixed = TRUE) # (d) Extra args are rejected, with the new "exactly" wording. testthat::expect_error( css(x, y, lambda = 0.01, fitfun = function(X, y, lambda, extra) 1L, B = 5), "must accept exactly the arguments", fixed = TRUE) }) ## Test passed with 4 successes. We also confirm the parallel feature-selection loop’s RNG is isolated per subsample (issue #12): cssLoop seeds the RNG immediately before fitfun, so a stochastic fitfun is reproducible and identical whether run serially or in parallel, given a seed set before css(). (The parallel checks require real forking, so they are guarded and skipped where forking is unavailable – Windows, CRAN, or a fully-loaded machine.) testthat::test_that("cssLoop seeds fitfun reproducibly; css parallel RNG is isolated (#12)", { set.seed(99) x_rng <- matrix(stats::rnorm(40 * 8), nrow=40, ncol=8) y_rng <- stats::rnorm(40) # A stochastic fitfun: randomly selects 2 features (uses the RNG), so its # output depends on the seed in effect when it runs. rfit <- function(X, y, lambda){ sort(sample.int(ncol(X), 2)) } sub <- sort(sample.int(40L, 20L)) # cssLoop's seed argument makes a stochastic fitfun reproducible: the same # seed gives the same selection. (On main, cssLoop has no seed argument, so # this behavior does not exist there.) This needs no parallelism. r1 <- cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=123L) r2 <- cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=123L) testthat::expect_identical(r1, r2) # ...and the seed genuinely drives the (stochastic) selection -- different # seeds give more than one distinct result (so the check above is not vacuous). outs <- lapply(1:8, function(s) cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=s)) testthat::expect_true(length(unique(outs)) > 1) # End-to-end, serial css is reproducible across re-runs. set.seed(1) d1 <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=1L)$feat_sel_mat set.seed(1) d2 <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=1L)$feat_sel_mat testthat::expect_identical(d1, d2) # Parallel checks need real forking; run the parallel css calls defensively # and skip (rather than fail) when forking is unavailable -- Windows, CRAN, or # a fully-loaded machine. A genuine reproducibility regression would still # surface as a failed expectation below, not a skip. par_runs <- tryCatch({ set.seed(1) a <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=2L)$feat_sel_mat set.seed(1) b <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=2L)$feat_sel_mat list(a=a, b=b) }, error=function(e) NULL) if(is.null(par_runs)){ testthat::skip("parallel forking unavailable in this environment") } testthat::expect_identical(par_runs$a, par_runs$b) # parallel reproducible testthat::expect_identical(par_runs$a, d1) # serial == parallel }) ## Test passed with 5 successes. We test the remaining num_cores robustness fixes (issue #155). parallel::detectCores() returns NA when the core count is indeterminable; that must not brick css() (#155c). We mock it and confirm the default num_cores = 1 still runs: testthat::test_that("detectCores() = NA does not brick css (#155c)", { set.seed(72) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings( detectCores = function(...) NA_integer_, .package = "parallel") res <- css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 1L) testthat::expect_s3_class(res, "cssr") }) ## Test passed with 1 success. …but when the core count IS known, the upper-bound guard must still fire, so an over-large num_cores is still rejected (#155c): testthat::test_that("num_cores beyond a known core count still errors (#155c)", { set.seed(72) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings( detectCores = function(...) 2L, .package = "parallel") testthat::expect_error( css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 5L), "num_cores <= n_cores_avail is not TRUE", fixed = TRUE) }) ## Test passed with 1 success. Finally (#155d), on Windows – where parallel::mclapply cannot fork – num_cores > 1 must downgrade to serial with a warning rather than hard-error. We mock the platform check so the branch is exercised off-Windows (it runs serially, so no real forking is needed): testthat::test_that("num_cores > 1 on Windows warns and runs serially (#155d)", { # Mocking a package-internal function needs a package context: local_mocked_bindings # resolves the package via testthat::testing_package(), which is set under # devtools::test and R CMD check but is empty during the bare litr weave (the cssr # functions live in the knit global env with no namespace to mock). Skip there; the # Windows branch is still exercised under devtools::test / R CMD check. if(testthat::testing_package() == ""){ testthat::skip("runningOnWindows mock needs a package context (unavailable during the litr weave)") } set.seed(84) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings(runningOnWindows = function() TRUE) testthat::expect_warning( res <- css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 2L), "not supported on Windows", fixed = TRUE) testthat::expect_s3_class(res, "cssr") }) ## -- Skip: num_cores > 1 on Windows warns and runs serially (#155d) -------------- ## Reason: runningOnWindows mock needs a package context (unavailable during the litr weave) We test the highly-discrete-response diagnostic (issue #131): the @noRd helper discreteYAbortProb() that estimates the abort probability, and the up-front css() warning it drives (which fires only for the default cssLasso, and only when the estimated probability exceeds 1%). testthat::test_that("discreteYAbortProb estimates the constant-subsample probability (#131)", { # Continuous y: every value is distinct, so no size-floor(n/2) subsample can # be constant. The aggregate underflows to exactly 0 -- assert the inequality, # NOT expect_equal to a tiny value. set.seed(131) y_cont <- stats::rnorm(100) testthat::expect_true(discreteYAbortProb(y_cont, 50L, "SS") < 1e-6) # Balanced binary at n = 100: each value's count (50) equals m = 50, so # p_const = 2 * C(50,50)/C(100,50) ~ 2e-29 and the aggregate underflows to 0. # This is the KEY false positive that the naive max(table(y)) >= floor(n/2) # trigger gets wrong (there count == m would fire). y_bin <- rep(0:1, each = 50) testthat::expect_true(discreteYAbortProb(y_bin, 50L, "SS") < 1e-6) # Skewed y (95/5): 0 is a strong majority (count 95 >> m = 50), so some # subsample is very likely all-zeros (~94% at B = 50, SS). y_skew <- c(rep(0, 95), rep(1, 5)) testthat::expect_true(discreteYAbortProb(y_skew, 50L, "SS") > 0.5) # Fully constant y: every subsample is constant -> probability exactly 1. testthat::expect_equal(discreteYAbortProb(rep(0, 100), 50L, "SS"), 1) # Monotone in n_sub: "SS" draws 2*B subsamples, a non-"SS" string draws B, so # the SS probability is at least the B-count probability for the same y. (Pure # helper call exercising the n_sub branch; not a css() run.) testthat::expect_true( discreteYAbortProb(y_skew, 50L, "SS") >= discreteYAbortProb(y_skew, 50L, "MB")) }) testthat::test_that("css() warns up front on a highly discrete y for the default cssLasso (#131)", { set.seed(2718) n <- 40L x_disc <- matrix(stats::rnorm(n * 6), nrow = n, ncol = 6) # 0 is a strong majority (count 38 >> floor(40/2) = 20), so the estimated # abort probability is ~99% -- well over the 1% threshold. y has 3 unique # values, so it passes input checks and reaches the warning. y_disc <- c(rep(0, 38), 1, 2) # (a) discrete y + default cssLasso -> the up-front warning fires. Such a run # also aborts later in the loop (a constant-y subsample), so wrap the call in # try(): the warning is computed before any subsampling/RNG and fires either # way (B = 10L so the small-B checkB warning does not also fire). testthat::expect_warning( try(css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L), silent = TRUE), "highly discrete", fixed = TRUE) # The warning message reports a plausible percentage and names cssLasso. disc_warns <- testthat::capture_warnings( try(css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L), silent = TRUE)) disc_msg <- disc_warns[grepl("highly discrete", disc_warns, fixed = TRUE)] testthat::expect_length(disc_msg, 1L) testthat::expect_match(disc_msg, "%", fixed = TRUE) testthat::expect_match(disc_msg, "cssLasso", fixed = TRUE) # (b) continuous y -> no warning at all (a clean, complete run). set.seed(2719) x_cont <- matrix(stats::rnorm(n * 6), nrow = n, ncol = 6) testthat::expect_no_warning( css(X = x_cont, y = stats::rnorm(n), lambda = 0.01, B = 10L)) # (c) balanced binary at n = 100 -> NO "highly discrete" warning (the KEY # false-positive guard). At small n balanced binary can legitimately warn, so # keep n large. Capture all warnings and assert none match. set.seed(2720) x_bin <- matrix(stats::rnorm(100 * 6), nrow = 100, ncol = 6) y_bin <- rep(0:1, each = 50) bin_warns <- testthat::capture_warnings( css(X = x_bin, y = y_bin, lambda = 0.01, B = 10L)) testthat::expect_false(any(grepl("highly discrete", bin_warns, fixed = TRUE))) # (d) custom fitfun with the SAME discrete y -> NO warning (proves the # identical(fitfun, cssLasso) gate). The stub ignores y (so it tolerates a # constant-y subsample) and returns a fixed, valid selected set. tol_fitfun <- function(X, y, lambda){ c(1L, 2L) } testthat::expect_no_warning( css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L, fitfun = tol_fitfun)) # (e) non-finite numeric y (majority Inf) + default cssLasso -> NO "highly # discrete" warning (proves the all(is.finite(sel_y)) guard). Without the # guard, table() would miscount the 38 Inf cells as a dominating value and # warn (~100%); with it, the diagnostic is skipped and cssLasso instead aborts # on the non-finite value (checkCssLassoInputs). Every size-floor(40/2) = 20 # subsample must include an Inf (only 2 finite cells), so the abort is # deterministic; wrap the warning-capture call in try(). y_nonfin <- c(rep(Inf, 38), 0, 1) nonfin_warns <- testthat::capture_warnings( try(css(X = x_disc, y = y_nonfin, lambda = 0.01, B = 10L), silent = TRUE)) testthat::expect_false(any(grepl("highly discrete", nonfin_warns, fixed = TRUE))) # ...and cssLasso still rejects the non-finite y (no warning to suppress now). testthat::expect_error( css(X = x_disc, y = y_nonfin, lambda = 0.01, B = 10L), "non-finite", fixed = TRUE) }) ## Test passed with 5 successes. ## Test passed with 9 successes. "],["tests-for-selection-and-prediction-functions.html", "9 Tests for selection and prediction functions", " 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 # checkGetCssPredsInputs() validates testX and trainX separately, and both # are unnamed here while the css X was named, so the warning fires once per # matrix. Collect rather than nesting two expect_warning() calls: the woven # chunks run at testthat edition 2 (no DESCRIPTION at the repo root), where # expect_warning() consumes every warning and a nested pair fails. Asserting # the length also turns an unexpected third warning into a failure (#186). # Keep both assertions: all(grepl(...)) is vacuously TRUE on an empty # vector, so expect_length() is what makes the pair non-blind. name_warns <- testthat::capture_warnings( 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_length(name_warns, 2) testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.", name_warns, 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))) }) ## Test passed with 126 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 # As at the checkGetCssPredsInputs site: testX and trainX are both unnamed, # so the warning fires once per matrix. Collected rather than nested for the # same edition-2 reason, and both assertions kept for the same reason (#186). name_warns <- testthat::capture_warnings( getCssPreds(css_res_named, testX=x_pred, trainX=x_train, trainY=y_train)) testthat::expect_length(name_warns, 2) testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.", name_warns, 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) }) ## Test passed with 68 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). # glmnet's own C++ convergence nag fires on this fixture. It is not # asserted, because that would pin a foreign optimizer's behavior, which can # differ across glmnet versions, platforms and BLAS. The predicate matches # glmnet's shared C++-error prefix, so it muffles that whole class -- a # tighter one would pin the very detail we are avoiding. Every non-glmnet # warning from this call still reaches the reporter (#186). css_no_train <- withCallingHandlers( css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10), warning = function(w) { if (grepl("from glmnet C++ code", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) # 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) }) ## 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)) }) ## Test passed with 20 successes. "],["tests-for-other-useful-functions.html", "10 Tests for other useful functions", " 10 Tests for other useful functions Tests for checkGenClusteredDataInputs() testthat::test_that("checkGenClusteredDataInputs works", { set.seed(7612) # Should get no error checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) # sig_clusters testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters="2", rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=4, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters <= n_clusters is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=-1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=.6, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters == round(sig_clusters) is not TRUE", fixed=TRUE) # n_clusters testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters="3", sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3.2, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters == round(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=0, sig_clusters=0, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=1, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "cluster_size >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=16, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "p >= n_clusters * cluster_size + k_unclustered is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "rho > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=0, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "beta_latent != 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=0, snr=1, sigma_eps_sq=NA), "beta_unclustered != 0 is not TRUE", fixed=TRUE) # k_unclustered testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered="2", cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=0, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2.2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered == round(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=NA), "Must specify one of snr or sigma_eps_sq", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) }) ## Test passed with 18 successes. Tests for getNoiseVar(): testthat::test_that("getNoiseVar works", { # getNoiseVar(rho) returns the noise variance v such that a proxy Z + N(0, v) # has correlation rho with Z, i.e. v = 1/rho^2 - 1 (vectorized; rho in (0, 1]). testthat::expect_equal(getNoiseVar(1), 0) testthat::expect_equal(getNoiseVar(0.5), 3) testthat::expect_equal(getNoiseVar(0.9), 1/0.81 - 1) testthat::expect_equal(getNoiseVar(c(0.5, 1, 0.9)), c(3, 0, 1/0.81 - 1)) # The defining property: a proxy with this noise variance has correlation rho. testthat::expect_equal(1/sqrt(1 + getNoiseVar(0.8)), 0.8) # rho must be numeric, non-NA, non-empty, and in (0, 1] (checks are vectorized). testthat::expect_error(getNoiseVar(0), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(-0.5), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(c(0.5, 0)), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(1.5), "all(rho <= 1) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(NA_real_), "all(!is.na(rho)) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar("0.5"), "is.numeric(rho) | is.integer(rho) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(numeric(0)), "length(rho) >= 1 is not TRUE", fixed=TRUE) }) ## Test passed with 12 successes. Finally, tests for genClusteredData() testthat::test_that("genClusteredData works", { set.seed(23478) ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:5])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:10])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:15])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .6) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 5) testthat::expect_equal(ncol(ret$Z), 1) # Bad inputs testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters="2", rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=4, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters <= n_clusters is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=-1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=.6, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters == round(sig_clusters) is not TRUE", fixed=TRUE) # n_clusters testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters="3", sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3.2, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters == round(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=0, sig_clusters=0, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=1, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "cluster_size >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(p=16, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "p >= n_clusters * cluster_size + k_unclustered is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "rho > 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=0, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "beta_latent != 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=0, snr=1, sigma_eps_sq=NA), "beta_unclustered != 0 is not TRUE", fixed=TRUE) # k_unclustered testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered="2", cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=0, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2.2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered == round(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=NA), "Must specify one of snr or sigma_eps_sq", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredData(n=5, p=19, k_unclustered=1, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(nrow(ret$X), 5) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 57 successes. Tests for genClusteredDataWeighted() testthat::test_that("genClusteredDataWeighted works", { set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:3])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:8])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:13])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .7) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 1) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=1, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 38 successes. Tests for genClusteredDataWeightedRandom() testthat::test_that("genClusteredDataWeightedRandom works", { set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:3])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:8])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:13])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .7) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 1) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=1, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 38 successes. Finally, characterization snapshots that pin the exact generated output of all three genClusteredData* generators. The “… works” tests above only check distributional properties (correlations, ranges), not the exact RNG draw order (which differs across the three: bulk rnorm vs per-column vs random per column). These snapshots make the #16 consolidation of the generators and their validators provably behavior-preserving; regenerate only if the data-generating algorithm intentionally changes. # Characterization snapshots: pin the EXACT generated values (X / y / Z / mu) # under fixed seeds so the #16 consolidation of the genClusteredData* functions # and their validators is provably behavior-preserving. The existing "... works" # tests only check distributional properties (correlations, ranges), NOT the # exact RNG draw order, which differs across the three generators (bulk vs # per-column vs random-per-column). Regenerate ONLY if the data-generating # algorithm intentionally changes. testthat::test_that("genClusteredData output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528, -0.113749750828501, -0.0540798505887575, -0.719018251689331, -1.02002920513898, -0.133167075802704, -0.228504275273568, -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392, -0.949501763500117, -1.09911307059764, -0.234373142554013, -0.0610136281766905, -0.614831158775111, -0.875588846521461, -0.267096146835881, 0.243882464912086, -0.525573959766865, 0.38889466127034, -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 7.85857128981734, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1): Z is a one-column matrix, and the # proxy block adds bulk noise to the raw vector Z. set.seed(23478) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-0.00161764234876749, -0.557794858227907, -0.827386446973581, -0.460377784885637, -2.67619233265038, 0.671711827459298, 1.65236925524076, -0.600115109545631, -0.280741265470752, -1.67026187144442, -0.0473803806232191, 0.0826508004462609, 0.170200984778884, 0.976190994120857, -0.499749723868518, -0.474295388720649, -1.17346153974724, -0.574655697546479, -0.120791507647279, -0.567678976454219, -1.3596277359555, -0.0619416164679036, 0.538496824968004, 0.51591446765952), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-0.558336409902388, -2.73369761842788, -0.884087327686163, -3.17343267752372)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(0.195781398124046, -1.51661095607912, -0.722190912632797, -2.90119777610212)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -5.88971766152033, sumY = -7.36101068003228, sumZ = -2.4782435456402, sumMu = -5.08843939501818)) }) testthat::test_that("genClusteredDataWeighted output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528, -0.113749750828501, -0.0540798505887575, -0.719018251689331, -1.02002920513898, -0.133167075802704, -0.228504275273568, -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392, -0.949501763500117, -0.748805376677026, 0.925796953277494, -0.766705940388196, -0.348877774329742, 1.96822115764394, 0.528035720534176, 2.93942827641455, 0.736079254765787, 0.38889466127034, -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 15.3829830134111, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1) set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.07114417787482, -0.368013007285506, 0.014438919713251, -0.845503147886515, -1.23739163512048, -0.174811089926991, -0.0829364724064908, -0.479069797377207, -1.12138274604786, -0.402828108682171, 0.104291325515473, -0.844159398768831, 0.352430473911601, -1.4960796572646, -1.23544829374631, 0.148162490964714, -1.03021388828778, 0.576416731940481, -0.513340292522171, -1.14008022670496, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795, 0.513991031913566, -2.95972727928473)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239, 0.564187042362111, -2.19774596140566)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -24.0234160115409, sumY = -10.2198990332918, sumZ = 0.586596841562748, sumMu = -5.15679097838167)) }) testthat::test_that("genClusteredDataWeightedRandom output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.1897691657824, -0.00982041549935259, 0.665172439447775, -0.756543570417209, 1.15949678203449, -2.91344510959381, 0.491240389956153, -1.30476423524191, -0.485131132932798, 0.707045727376943, 3.2222522503854, -3.27350445562509, -1.85428176680484, -0.0656090373877866, -0.551130785327929, -1.90090513408521, -1.29616909361208, -0.144918159176611, 0.544180897409365, -0.50148178532334, 0.627200376817289, 0.171599744439457, -1.07507438640901, 1.5693792481444), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 3.23025166163967, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1) set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.36526166060881, 0.586409931283558, 1.2227469255493, -2.17655371414979, 0.326418806550987, -1.09714072579561, 1.4239012653582, -0.760011975131564, -0.227256340192126, -1.84845832529723, 0.184388770399019, -0.394752299747441, -1.47062212216842, -0.12215942773548, -0.0749451055463801, -0.842364831584477, -1.41223753691949, -1.68487949598676, 0.247717311839652, -1.86068883953814, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795, 0.513991031913566, -2.95972727928473)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239, 0.564187042362111, -2.19774596140566)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -28.8273582900822, sumY = -10.2198990332918, sumZ = 0.586596841562748, sumMu = -5.15679097838167)) }) ## Test passed with 10 successes. ## Test passed with 10 successes. ## Test passed with 10 successes. The two weighted generators now run the same snr / sigma_eps_sq type checks as genClusteredData() (#35): a non-numeric snr / sigma_eps_sq is rejected up front rather than silently passing the old lean check and failing later inside genZmuY(). testthat::test_that("genClusteredData* reject n < 2 and non-integer cluster_size / p (#70)", { ok <- list(n = 10, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1, sig_clusters = 1, sigma_eps_sq = 1) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(n = 1L))), "n >= 2", fixed = TRUE) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(cluster_size = 2.5))), "cluster_size == round(cluster_size)", fixed = TRUE) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(p = 8.5))), "p == round(p)", fixed = TRUE) # n = 2 is the tight boundary -- it must still WORK (locks the threshold # against a future "n >= 3" / "> 2" regression). res2 <- do.call(genClusteredData, utils::modifyList(ok, list(n = 2L))) testthat::expect_equal(nrow(res2$X), 2L) # The shared genZmuY n-guard and the shared Pre cluster_size check cover the # weighted generators too: wok <- list(n = 1L, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1, n_strong_cluster_vars = 2, sig_clusters = 1, rho_high = 0.8, rho_low = 0.2, sigma_eps_sq = 1) testthat::expect_error(do.call(genClusteredDataWeighted, wok), "n >= 2", fixed = TRUE) testthat::expect_error( do.call(genClusteredDataWeighted, utils::modifyList(wok, list(n = 10L, cluster_size = 2.5))), "cluster_size == round(cluster_size)", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted/Random validate snr/sigma_eps_sq type (#35)", { # Newly rejected (these previously slipped past the weighted validators' lean # checks and only failed later, cryptically, inside genZmuY). testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1", sigma_eps_sq=NA), "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"), "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1", sigma_eps_sq=NA), "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"), "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE) # Range checks (snr > 0, sigma_eps_sq >= 0) are unchanged by #35. testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) # A valid scalar numeric snr / sigma_eps_sq is still accepted. ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) }) testthat::test_that("genClusteredData rejects rho > 1 up front (#162)", { # The documented upper bound is now enforced by the up-front checker, so the # message names the user's argument rho instead of surfacing from deep # inside getNoiseVar(). Split one case per block: under testthat edition 3, # which this package declares, expect_error() re-raises on a message mismatch # and aborts the rest of its block, so bundling would hide the red side of # every case after the first. The edition is load-bearing -- at edition 2 the # block continues instead, so measuring this outside a package context (where # edition 2 is the default) measures the wrong semantics. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1.2, sigma_eps_sq = 1), "rho <= 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects a non-numeric rho (#162)", { # Without the type check this slipped through: stopifnot("0.8" > 0) is TRUE, # because R compares character to numeric as strings. It then failed later, # inside getNoiseVar(). # # The message alone stopped being a sufficient guard when #181 renamed # getNoiseVar()'s formal cor -> rho: the validator's check and getNoiseVar()'s # are now the SAME line, so both raise # is.numeric(rho) | is.integer(rho) is not TRUE # and the string can no longer tell "rejected up front" from "died late # inside getNoiseVar()". Measured: deleting the validator's type check leaves # this block green if it pins only the message, because "0.8" > 0 and # "0.8" <= 1 are both TRUE (string comparison), so a character rho reaches # genZmuY(), draws from the stream, and dies in getNoiseVar() raising the # identical condition. # # The RNG state distinguishes the two frames no matter what the message says, # and early rejection is what #162 was actually about -- so assert it here # rather than relying on a string that two independent guards now share. set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = "0.8", sigma_eps_sq = 1), "is.numeric(rho) | is.integer(rho) is not TRUE", fixed = TRUE) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredData rejects a length > 1 rho (#162)", { # Previously NO error at all. A length-2 rho produced a length-2 noise # variance, which rnorm() recycles elementwise over its flat draw, so the # noise sd alternated row by row WITHIN every proxy column. Measured on the # pre-fix code with rho = c(0.9, 0.5) and seed 1, the eight proxy # correlations were 0.58 0.25 0.55 0.52 0.47 0.60 0.58 0.47 -- every one # corrupted, none at either requested value. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = c(0.9, 0.5), sigma_eps_sq = 1), "length(rho) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects a missing rho (#162)", { # Previously reported the misleading "rho > 0 is not TRUE". testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = NA_real_, sigma_eps_sq = 1), "!is.na(rho) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects rho before drawing any random numbers (#162)", { # "Up front" is the point of the issue, so assert it directly: a rejected # rho must not have advanced the RNG. Before the fix, rho = 1.2 died inside # getNoiseVar() only after genZmuY() had already drawn from the stream. # The expect_error() below deliberately asserts no message: this block's # subject is the RNG state, and the message for this exact input is already # pinned by the "rejects rho > 1 up front" block above. set.seed(20260815) seed_before <- .Random.seed testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1.2, sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredData keeps rejecting rho <= 0 (#162)", { # The lower bound is unchanged; this locks its message against the reorder. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 0, sigma_eps_sq = 1), "rho > 0 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData accepts rho = 1, the tight upper boundary (#162)", { # rho = 1 must still WORK, so the new bound is <= and not <. getNoiseVar(1) # is exactly 0, so every proxy is a noiseless copy of its latent column -- # a seed-independent identity, and a far stronger lock than dim(X), which # would hold at any rho. set.seed(20260815) res <- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1, sigma_eps_sq = 1) testthat::expect_equal(dim(res$X), c(50L, 13L)) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res$X[, 1:8], Z_expanded) }) testthat::test_that("genClusteredDataWeighted enforces the documented n_strong_cluster_vars range (#162, refs #164)", { # Both bounds already errored; these are the negative tests that were # missing (#164) for the constraint now documented on the help page. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 0, n_clusters = 2, sigma_eps_sq = 1), "n_strong_cluster_vars >= 1 is not TRUE", fixed = TRUE) # An all-strong cluster is a natural request and is rejected: the second # proxy loop would run (cluster_size + 1):cluster_size, which descends # rather than being empty, so it writes the NEXT cluster's first proxy # column -- and on the final cluster that index is past ncol(proxy_mat), so # the unguarded loop dies with "subscript out of bounds". The guard trades # that obscure indexing error for one naming the argument. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 4, n_clusters = 2, sigma_eps_sq = 1), "n_strong_cluster_vars < cluster_size is not TRUE", fixed = TRUE) # Interior values are accepted AND split the columns as documented. With # rho_high = 1 the strong proxies are noiseless copies of their latent # column and the weak ones are not, which locks the split itself rather # than just the shape of X. n = 500 rather than 50 so that the weak-proxy # correlation check below discriminates: measured at n = 50, a rho_low = 0.5 # proxy's sample correlation was 0.33 while pure independent noise reached # 0.48 over 200 draws, so any threshold there would be vacuous. At n = 500 # the weak proxies measure ~0.53 and pure noise tops out at 0.16. set.seed(20260815) res <- genClusteredDataWeighted(n = 500, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = 0.5, sigma_eps_sq = 1) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] strong <- c(1:3, 5:7) weak <- c(4L, 8L) testthat::expect_equal(res$X[, strong], Z_expanded[, strong]) testthat::expect_false(any(res$X[, weak] == Z_expanded[, weak])) # The weak proxies must still carry the latent signal at roughly rho_low, and # this is a two-sided band rather than a floor on purpose. A one-sided # "> 0.3" passes a bug that hands the weak proxies rho_high instead # (measured: weak_cor 0.951, 0.956) -- which is precisely the strong/weak # split failure this block exists to catch, so a floor would be blind to it. # At n = 500 the sampling sd of the correlation is ~0.034 and the seed is # fixed, so a 0.1 band is ~3 sd wide: the correct values sit 0.028 and 0.040 # away from rho_low, while pure noise (~0) and a rho_high mix-up (~0.95) both # fall well outside. weak_cor <- vapply(weak, function(j) stats::cor(res$X[, j], Z_expanded[, j]), numeric(1)) testthat::expect_true(all(abs(weak_cor - 0.5) < 0.1)) testthat::expect_false(anyNA(res$X)) }) testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_high (#181)", { # Previously slipped past all four range checks and died inside # getNoiseVar(), naming that helper's formal rather than the user's # argument, and only after the RNG had already advanced. The type check has # to precede every range check: stopifnot("0.9" >= 0.5) is TRUE, because R # coerces the number to a string and compares as strings rather than # erroring. ("10" >= 9 is FALSE, which is the giveaway that it is a string # comparison and not a numeric one.) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_high (#181)", { # The same hole with a different landing place: this generator reached # runif(n = 1, min = rho_low, max = rho_high) and reported the opaque # "invalid arguments", again only after advancing the RNG. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_low (#181)", { # As for rho_high: the string comparison rho_high >= rho_low is TRUE for # "0.2", so the old range checks passed it straight through to getNoiseVar(). testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = "0.2", sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_low (#181)", { # Previously reported runif()'s "invalid arguments", after advancing the RNG. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = "0.2", sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a logical rho_high (#181)", { # A logical argument is the same type hole, but the two generators failed # very differently. genClusteredDataWeighted() errored naming getNoiseVar()'s # formal, while genClusteredDataWeightedRandom() accepted TRUE outright (the # block below) -- so the pair belongs to the silent-wrong-answer class, not # merely the bad-message class. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_high (#181)", { # Previously NO error at all: runif(1, 0.5, TRUE) coerces TRUE to 1, so the # call returned a data set silently generated at rho_high = 1 instead of # rejecting an argument that is not a correlation. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a logical rho_low (#181)", { # rho_high = 1 is deliberate. This input errors at either setting, but at # rho_high = 1 the pre-change code advanced the RNG before dying inside # getNoiseVar(), whereas at rho_high = 0.9 the ordering check caught it with # the stream untouched -- blaming the ordering for what is a type error. The # rho_high = 1 variant is the worse defect, so it is the one to lock. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_low (#181)", { # rho_high = 1 is load-bearing here for a different reason: it is this # generator's DEFAULT, and the only setting under which rho_low = TRUE was # accepted at all -- runif(1, TRUE, 1) coerces TRUE to 1, so the call # silently returned data. A silent wrong answer on the default path. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_high (#181)", { # Previously NO error at all -- the silent-wrong-answer case this issue was # filed about. genClusteredDataWeighted() calls getNoiseVar() once per # argument and then draws per column, rnorm(n, sd = sqrt(noise_var_high)), # so a length-2 argument makes sd length 2 and rnorm() recycles it # elementwise DOWN the column: the noise sd alternates row by row within # every column that argument governs. The columns governed by the other, # scalar argument keep exactly the correlation they asked for. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_high (#181)", { # Previously NO error either, but by a different route: this generator does # no recycling at all. The argument reaches # runif(n = 1, min = rho_low, max = rho_high), which uses the FIRST element # and discards the rest without a word. Truncation, not corruption -- the # two generators are not failing the same way. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_low (#181)", { # Previously NO error, and this is the case whose corrupted value has a # closed form worth recording. Recycling sd = sqrt(c(3, 10.1111)) # elementwise down a column makes the noise VARIANCE alternate, so the # column's marginal noise variance is the mean of the two and BOTH weak # columns land on # 1/sqrt(1 + mean(c(getNoiseVar(0.5), getNoiseVar(0.3)))) = 1/sqrt(1 + # 6.5556) = 0.3638 -- neither requested value, and identical for the two of # them. That is the population value, not a sample estimate: quoting a # measured pair would imply a between-column difference that does not exist, # and every seed produces a different pair. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1), "length(rho_low) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_low (#181)", { # Previously NO error: the same first-element truncation as for rho_high. # Measured on the pre-change tree at a fixed seed, the returned X was # identical() to the rho_low = 0.5 run and not to the rho_low = 0.3 run. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3), sigma_eps_sq = 1), "length(rho_low) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a zero-length rho_high (#181)", { # All four range checks are STRUCTURALLY INERT against a zero-length # argument: numeric(0) <= 1 is logical(0), and all(logical(0)) is TRUE, so # stopifnot() does not error. The call therefore reached getNoiseVar() and # reported that helper's formal. NULL is in the same family but is NOT # interchangeable -- is.numeric(NULL) is FALSE, so NULL is caught by the # TYPE check and never reaches the length check. numeric(0) is the input # that exercises the length check at its zero end. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a zero-length rho_high (#181)", { # The same inert range checks. Here the call got as far as runif(), which # returned NA with a "NAs produced" warning, and the failure then surfaced # from inside getNoiseVar() rather than naming rho_high. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a missing rho_high (#181)", { # Previously reported the misleading "rho_high <= 1 is not TRUE" -- a range # bound blamed for a missingness problem, which sends the user off checking # a value that is not the issue. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1), "!is.na(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_high (#181)", { # Same misleading "rho_high <= 1 is not TRUE" before the change. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1), "!is.na(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a missing rho_low (#181)", { # Previously reported "rho_low > 0 is not TRUE" -- the lower bound this # time rather than the upper one, but the identical class: a range bound # blamed for missingness. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = NA_real_, sigma_eps_sq = 1), "!is.na(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_low (#181)", { # Same misleading "rho_low > 0 is not TRUE" before the change. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = NA_real_, sigma_eps_sq = 1), "!is.na(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted checks rho_high's length before its missingness (#181)", { # This block exists for the FINE ordering -- length before NA -- which every # other block here is blind to. Only an input that is simultaneously length # > 1 AND contains NA can tell the two orderings apart: measured, the # shipped order reports the length violation below, while checking !is.na() # first reports the confusing plural "!is.na(rho_high) are not all TRUE", # because !is.na() is vectorized. Before the change this input reported # neither, dying in the range checks with "rho_high <= 1 are not all TRUE". testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom checks rho_high's length before its missingness (#181)", { # The fine-ordering lock for the second generator; see the block above for # why an input that is both length > 1 and NA-containing is the only one # that distinguishes the two orderings. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted* reject rho_high/rho_low before drawing any random numbers (#181)", { # "Up front" is the point of the issue, so assert it directly. A length-2 # argument is the right probe: it advanced the RNG in both generators before # the change, whereas an NA argument was already caught by a range check # with the stream untouched and so would prove nothing. # This block stays BUNDLED across both generators, unlike every block above. # Its expect_error() calls carry no message argument, so they cannot # mismatch, so they cannot re-raise and abort the block under testthat # edition 3 -- all four assertions are reached even when all four fail. set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3), sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredDataWeighted* still accept the boundary rho values (#181)", { # rho = 1 must still WORK, so the bound is <= and not <. getNoiseVar(1) is # exactly 0, so every proxy is a noiseless copy of its latent column -- a # seed-independent identity, and a far stronger lock than dim(X), which # would hold at any rho. Passing rho_high = rho_low = 1 hits the upper # boundary and the rho_high == rho_low boundary at once. set.seed(20260817) res <- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = 1, sigma_eps_sq = 1) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res$X[, 1:8], Z_expanded) # rho_high is OMITTED here, so its default of 1 applies: one call covering # the upper boundary, the rho_high == rho_low boundary, and the default path # the issue's closing note asks about. runif(1, 1, 1) is exactly 1, so the # same noiseless identity holds for this generator too. set.seed(20260817) res_rand <- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_low = 1, sigma_eps_sq = 1) Z_expanded_rand <- as.matrix(res_rand$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res_rand$X[, 1:8], Z_expanded_rand) }) testthat::test_that("genClusteredDataWeighted* keep their existing rho range messages (#181)", { # What this locks, precisely: the four range checks survive the move into # checkRhoHighLow() with their exact messages. It is GREEN on the pre-change # tree by design -- it locks behavior that must not change, so its power # comes from mutation rather than from a red side. It is the only block in # this set that notices if one of the four checks is dropped. # # It does NOT lock their order, and two reorderings are invisible to it. # Swapping > 0 against <= 1 is invisible because once length-1 and non-NA # are established at most one of those two can fail on a scalar, so the # orders are observationally identical. Swapping rho_low > 0 against # rho_high >= rho_low is invisible for a different reason: measured, all # four inputs below report the same message either way, because whichever # of the two is violated is still the first of them to fail. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1), "rho_high <= 1 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1), "rho_high > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1), "rho_low > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1), "rho_high >= rho_low is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1), "rho_high <= 1 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1), "rho_high > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1), "rho_low > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1), "rho_high >= rho_low is not TRUE", fixed = TRUE) }) ## Test passed with 6 successes. ## Test passed with 7 successes. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 6 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 4 successes. ## Test passed with 2 successes. ## Test passed with 8 successes. Edge-case regression tests for genZmuY() (the shared core all three generators funnel through), covering the two bugs fixed in #124: a missing drop = FALSE that crashed the exactly-one-weak-signal/noise-feature configuration, and a sig_clusters == 0 case that silently kept a latent cluster in the true model for y instead of yielding a null latent model. The fix consumes NO randomness (only deterministic reshaping of mu), so every generator test and characterization snapshot above stays byte-identical. testthat::test_that("genZmuY one-weak-signal config no longer crashes, all 3 generators (#124 bug 1)", { # p == n_clusters*cluster_size + 1 leaves exactly ONE weak-signal/noise # feature, so other_X had a single column; without drop = FALSE it collapsed # to a vector and other_X[, j] errored "incorrect number of dimensions". The # pre-check only requires p_orig_feat_mat >= k_unclustered + n_clusters # (here 2 >= 2), so it passed straight into the crash. ret <- genClusteredData(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, snr = 2) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 3) testthat::expect_equal(nrow(ret$X), 20) # genClusteredDataWeighted: n_strong_cluster_vars is REQUIRED and its checker # enforces >= 1 AND < cluster_size, so with cluster_size = 2 the only valid # value is 1. retW <- genClusteredDataWeighted(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, n_strong_cluster_vars = 1, snr = 2) testthat::expect_true(is.list(retW)) testthat::expect_identical(names(retW), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(retW$X), 3) retR <- genClusteredDataWeightedRandom(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, snr = 2) testthat::expect_true(is.list(retR)) testthat::expect_identical(names(retR), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(retR$X), 3) }) testthat::test_that("genZmuY sig_clusters == 0 yields a null latent model (#124 bug 2)", { # The zero-beta case MUST bypass genClusteredData: its validator rejects # beta_unclustered == 0 / beta_latent == 0, so exercise the internal helper # directly. sig_clusters == 0 AND beta_unclustered == 0 => mu is exactly 0 # (no latent term, no weak-signal term). set.seed(53) g0 <- genZmuY(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, sig_clusters = 0, beta_latent = 1.5, beta_unclustered = 0, snr = NA, sigma_eps_sq = 0.5) testthat::expect_true(all(g0$mu == 0)) # Contrast, n_clusters > 1: reset the seed before EACH call so the SAME # orig_feat_mat (hence the same Z and weak-signal block) is drawn; then # g1$mu - g0$mu isolates the pure latent term Z[, 1] * beta_latent. cfgA <- list(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, beta_latent = 1.5, beta_unclustered = 1, snr = NA, sigma_eps_sq = 0.5) set.seed(51) g0A <- do.call(genZmuY, c(cfgA, sig_clusters = 0)) set.seed(51) g1A <- do.call(genZmuY, c(cfgA, sig_clusters = 1)) testthat::expect_equal(g1A$Z, g0A$Z) # same orig_feat_mat drawn testthat::expect_false(all(g0A$mu == 0)) # weak signal still retained testthat::expect_equal(g1A$mu - g0A$mu, as.numeric(g1A$Z[, 1] * 1.5)) # Lock the n_clusters > 1 & sig_clusters == 1 branch with an explicit # expected value (no characterization snapshot covers it). testthat::expect_equal(g1A$mu[1:4], c(1.71187484261165, -1.8816097377914, -0.434623721956133, 0.201053072650191)) # Contrast, n_clusters == 1 (Z is a bare vector; the else branch). cfgB <- list(n = 20, p = 4, k_unclustered = 1, cluster_size = 2, n_clusters = 1, beta_latent = 1.5, beta_unclustered = 1, snr = NA, sigma_eps_sq = 0.5) set.seed(52) g0B <- do.call(genZmuY, c(cfgB, sig_clusters = 0)) set.seed(52) g1B <- do.call(genZmuY, c(cfgB, sig_clusters = 1)) testthat::expect_equal(g1B$mu - g0B$mu, as.numeric(g1B$Z * 1.5)) testthat::expect_equal(g1B$mu[1:4], c(-1.35778032140589, 0.59232273049822, 2.44822804281879, -0.29256382836018)) # End-to-end: genClusteredData with sig_clusters = 0 and NONZERO default # betas returns valid data (no error; the weak-signal features still # legitimately contribute, only the latent part is zeroed). ret <- genClusteredData(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, sig_clusters = 0, sigma_eps_sq = 0.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 6) }) ## Test passed with 11 successes. ## Test passed with 10 successes. Tests for getLassoLambda(): testthat::test_that("getLassoLambda works", { set.seed(7252) x <- matrix(stats::rnorm(10*6), nrow=10, ncol=6) y <- stats::rnorm(10) ret <- getLassoLambda(X=x, y=y, lambda_choice="1se", nfolds=4) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) # Different mixing parameter ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5, alpha=0.5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) # data.frame X is now accepted (coerced internally), like the sibling exports (#51) ret_df <- getLassoLambda(X = as.data.frame(x), y = y, lambda_choice = "1se", nfolds = 4) testthat::expect_true(is.numeric(ret_df) | is.integer(ret_df)) testthat::expect_true(!is.na(ret_df)) testthat::expect_equal(length(ret_df), 1) testthat::expect_true(ret_df >= 0) # Bad inputs testthat::expect_error(getLassoLambda(X="x", y=y), "must be a numeric matrix", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x[1:9, ], y=y), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=TRUE), "must be a numeric (real-valued) vector", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice="mni")) testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=c("min", "1se")), "length(lambda_choice) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=1), "is.character(lambda_choice) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds="5"), "is.numeric(nfolds) | is.integer(nfolds) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=1:4), "length(nfolds) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=3.2), "nfolds == round(nfolds) is not TRUE", fixed=TRUE) # (#158e) nfolds=3 is cv.glmnet's minimum and is now accepted. ret <- getLassoLambda(X=x, y=y, nfolds=3) testthat::expect_true(is.numeric(ret) && length(ret) == 1 && ret >= 0) # nfolds=2 (below the minimum) is rejected at the new boundary. testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=2), "nfolds >= 3 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=1.2), "alpha <= 1 is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is now rejected (previously allowed) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # An NA in the design matrix now yields a friendly message (#56) rather than # falling through to a cryptic glmnet-level error. x_na <- x; x_na[2, 1] <- NA testthat::expect_error(getLassoLambda(X=x_na, y=y), "must not contain missing", fixed=TRUE) # A data.frame with a numeric NA must error with the same message BEFORE # coercion: model.matrix's na.action=na.omit would otherwise silently drop # the NA row and the failure would surface downstream (length mismatch), not # as this message. This case pins the pre-coercion placement of checkNoNAs. df_na <- as.data.frame(x); df_na[2, 1] <- NA testthat::expect_error(getLassoLambda(X=df_na, y=y), "must not contain missing", fixed=TRUE) # (#104, L7) When n is too small for even 3-fold cross-validation, error # clearly here instead of crashing inside cv.glmnet ("nfolds must be bigger # than 3"). With n = 4 and the default nfolds = 10, n_sample rounds to 2 (< 3). testthat::expect_error( getLassoLambda(X=matrix(stats::rnorm(4*5), nrow=4, ncol=5), y=stats::rnorm(4)), "is too small to choose lambda", fixed=TRUE) # (#127) A single-column X now fires the same clean "p >= 2 is not TRUE" # message as css(), rather than crashing later inside cv.glmnet. testthat::expect_error( getLassoLambda(X=matrix(stats::rnorm(40), nrow=40, ncol=1), y=stats::rnorm(40)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 33 successes. Out-of-range cluster indices are caught up front (#104, L3) through the public css() and protolasso() entry points – covering a bare-vector clusters argument (which is wrapped into a list after the per-element validation loop) and a list clusters argument: testthat::test_that("out-of-range cluster indices error via css/protolasso (#104)", { set.seed(104105) X <- matrix(stats::rnorm(20*8), nrow=20, ncol=8) y <- stats::rnorm(20) # Bare-vector clusters with an index beyond p (= 5 here). testthat::expect_error( css(X[, 1:5], y, lambda=0.01, clusters=c(1, 2, 99)), "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE) # List clusters routed through protolasso. testthat::expect_error( protolasso(X[, 1:5], y, clusters=list(c(1, 2, 99))), "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE) }) ## Test passed with 2 successes. css() reports a too-small sample size clearly (#104, L4) instead of the misleading “Too many training indices provided” when no training indices were supplied: testthat::test_that("css reports a too-small sample size clearly (#104)", { set.seed(104104) # No train_inds: the message must blame the sample size, not training indices. testthat::expect_error( css(matrix(stats::rnorm(15), nrow=3, ncol=5), stats::rnorm(3), lambda=0.01), "is too small", fixed=TRUE) # When train_inds leave fewer than 4 observations for selection, the original # "Too many training indices" branch still fires. testthat::expect_error( css(matrix(stats::rnorm(10*5), nrow=10, ncol=5), stats::rnorm(10), lambda=0.01, train_inds=1:7), "Too many training indices provided", fixed=TRUE) }) ## Test passed with 2 successes. Tests for getModelSize(): testthat::test_that("getModelSize works", { set.seed(1723) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) ret <- getModelSize(X=x, y=y, clusters=good_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but two clusters of size 3, so maximum size should # be 11 - 2 - 2 = 7 testthat::expect_true(ret <= 7) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) ret <- getModelSize(X=x, y=y, clusters=unnamed_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 3 in one cluster and 4 in another, so maximum size should # be 11 - 2 - 3 = 6 testthat::expect_true(ret <= 6) # Single cluster ret <- getModelSize(X=x, y=y, clusters=2:5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 4 in one cluster, so maximum size should be 11 - 3 = 8 testthat::expect_true(ret <= 8) # Regression test: when prototype reduction leaves a single column (all # provided features in one cluster), getModelSize must return 1L rather than # crashing in cv.glmnet. Previously X_size[, -feats_to_drop] dropped to a # vector when one column remained. testthat::expect_equal(getModelSize(X=x[, 1:3, drop=FALSE], y=y, clusters=list(1:3)), 1L) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1:3, 5:8) ret <- getModelSize(X=x, y=y, clusters=good_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 3 in one cluster and 4 in another, so maximum size should # be 11 - 2 - 3 = 6 testthat::expect_true(ret <= 6) ## Trying bad inputs testthat::expect_error(getModelSize(X="x", y=y, clusters=good_clusters), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x[1:5, ], y=y, clusters=good_clusters), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=FALSE, clusters=good_clusters), "must be a numeric (real-valued) vector", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(3:7, 7:10)), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): the model size for a # duplicated cluster equals that of the deduplicated input. getModelSize is # stochastic (cv.glmnet), so seed both calls identically. set.seed(15678) dup_ms <- getModelSize(X=x, y=y, clusters=list(5:8, 5:8)) set.seed(15678) dedup_ms <- getModelSize(X=x, y=y, clusters=list(5:8)) testthat::expect_equal(dup_ms, dedup_ms) # Out-of-range cluster index now caught up front by checkFormatClustersInput # (#104, L3); x has 11 columns, so index 50 is out of range. testthat::expect_error(getModelSize(X=x, y=y, clusters=6:50), "Cluster index 50 exceeds the number of features (p = 11).", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, as.integer(NA))), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, c(4, 4, 5))), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, -1)), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, c(2.3, 1.2))), "all(clusters[[i]] == round(clusters[[i]])) is not TRUE", fixed=TRUE) ## alpha (#21): the elastic-net mixing parameter now drives the model-size ## estimate (the internal cv.glmnet), keeping it consistent with elastic-net ## feature selection. # Validation, mirroring getLassoLambda: alpha must be in (0, 1]. testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=NA), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) # Back-compat: default is pure lasso (alpha = 1). cv.glmnet uses random CV # folds, so seed before each call to compare apples-to-apples. set.seed(7); a_default <- getModelSize(X=x, y=y, clusters=good_clusters) set.seed(7); a_alpha1 <- getModelSize(X=x, y=y, clusters=good_clusters, alpha=1) testthat::expect_equal(a_default, a_alpha1) # Headline: on a design with a block of highly correlated relevant features # (each feature its own singleton cluster, so cv.glmnet sees the whole block # with no prototype reduction), a lower alpha (elastic net) keeps more of the # correlated features than pure lasso, giving a strictly larger estimated # size. On main, getModelSize has no alpha argument, so this cannot happen. set.seed(2718) n_h <- 120 z_h <- stats::rnorm(n_h) X_block <- matrix(rep(z_h, 10), nrow=n_h) + matrix(stats::rnorm(n_h * 10, sd=0.05), nrow=n_h) X_noise <- matrix(stats::rnorm(n_h * 4), nrow=n_h) X_h <- cbind(X_block, X_noise) y_h <- 2 * z_h + stats::rnorm(n_h, sd=0.5) singletons_h <- as.list(1:ncol(X_h)) set.seed(11) size_lasso <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=1) set.seed(11) size_enet <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=0.2) testthat::expect_true(size_enet >= size_lasso) testthat::expect_true(size_enet > size_lasso) }) ## Test passed with 41 successes. These two functions are the package’s only cv.glmnet call sites, and #186’s fix is a grouped argument on each. This block is what observes that fix: testthat::test_that("small-n cv.glmnet calls do not leak glmnet's fold-size nag (#186)", { set.seed(186) X <- matrix(stats::rnorm(20 * 6), nrow = 20, ncol = 6) y <- as.numeric(X %*% c(1, -1, 0, 0, 0, 0) + stats::rnorm(20)) # n = 20 puts both calls under glmnet's nrow(x)/nfolds < 3 rule -- getLassoLambda # subsamples 11 rows over 10 folds, getModelSize passes all 20 over 10 -- so # without the explicit grouped argument cv.glmnet warns here. capture_warnings() # rather than expect_no_warning() because the woven chunks run at testthat # edition 2, where this form behaves the same as it does under devtools::test(). lambda_warns <- testthat::capture_warnings(lambda <- getLassoLambda(X = X, y = y)) testthat::expect_length(lambda_warns, 0) testthat::expect_true(is.numeric(lambda) & length(lambda) == 1) size_warns <- testthat::capture_warnings( size <- getModelSize(X = X, y = y, clusters = list(1:3))) testthat::expect_length(size_warns, 0) testthat::expect_true(is.integer(size) & size >= 1) # The user-visible half of #186: under options(warn = 2) the unguarded calls # became errors, so cssSelect()/cssPredict() were unusable at small n. old_warn <- options(warn = 2) on.exit(options(old_warn), add = TRUE) testthat::expect_no_error(getLassoLambda(X = X, y = y)) testthat::expect_no_error(getModelSize(X = X, y = y, clusters = list(1:3))) }) ## Test passed with 6 successes. Tests for getSelectionPrototypes(): testthat::test_that("getSelectionPrototypes works", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters) ret <- getSelectionPrototypes(css_results, selected_clusts=good_clusters) testthat::expect_true(is.integer(ret)) testthat::expect_true(all(!is.na(ret))) testthat::expect_equal(length(ret), length(good_clusters)) testthat::expect_equal(length(ret), length(unique(ret))) for(i in 1:length(ret)){ testthat::expect_true(ret[i] %in% good_clusters[[i]]) # Find the largest selection proportion of any feature in cluster i max_prop <- max(colMeans(css_results$feat_sel_mat[, good_clusters[[i]]])) # Find the selection proportion of the identified prototype proto_prop <- colMeans(css_results$feat_sel_mat)[ret[i]] testthat::expect_equal(max_prop, proto_prop) } # Try with only one selected cluster (still should be in a list) ret <- getSelectionPrototypes(css_results, selected_clusts=list(red_cluster=1L:3L)) testthat::expect_true(is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret %in% 1L:3L) # Find the largest selection proportion of any feature in the cluster max_prop <- max(colMeans(css_results$feat_sel_mat[, 1L:3L])) # Find the selection proportion of the identified prototype proto_prop <- colMeans(css_results$feat_sel_mat)[ret] testthat::expect_equal(max_prop, proto_prop) ## Trying bad inputs # Error contains quotation marks testthat::expect_error(getSelectionPrototypes(x, good_clusters)) testthat::expect_error(getSelectionPrototypes(css_results, 1L:3L), "is.list(selected_clusts) is not TRUE", fixed=TRUE) # An empty selection (empty list of selected clusters) is valid post-#107: # getSelectionPrototypes() returns an empty integer vector, no error (#120). testthat::expect_identical(getSelectionPrototypes(css_results, list()), integer(0)) testthat::expect_error(getSelectionPrototypes(css_results, list(red_cluster=1L:3L, green_cluster=4L:6L, bad_cluster=integer())), "all(lengths(selected_clusts) >= 1) is not TRUE", fixed=TRUE) }) testthat::test_that("getSelectionPrototypes handles a constant tied column without crashing (#68)", { set.seed(680) n <- 20L; p <- 4L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) X[, 2] <- 3.5 # feature 2 is a CONSTANT column colnames(X) <- paste0("V", 1:p) y <- X[, 1] + stats::rnorm(n) # y correlated with feature 1 (varying) # feat_sel_mat: features 1 and 2 tie at selection proportion 0.5 (both # "selected" in the same 5 of 10 subsamples), forcing the tie-break path. B <- 10L M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L M[1:5, 2] <- 1L css_results <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # Pre-fix: cor(X[, c(1,2)], y) -> c(<corr>, NA) -> max NA -> stopifnot abort. proto <- getSelectionPrototypes(css_results, selected_clusts = list(c(1L, 2L))) testthat::expect_false(is.na(proto)) testthat::expect_identical(unname(proto), 1L) # the varying, y-correlated member # All-constant tied cluster: must not crash, picks the first deterministically. # (suppressWarnings: the names-assignment emits a pre-existing "number of items # to replace..." warning when proto_i stays length>1; not introduced by this # fix, unrelated to #68.) X2 <- X; X2[, 3] <- 2.0; X2[, 4] <- 9.0 M2 <- matrix(0L, nrow = B, ncol = p); M2[1:5, 3] <- 1L; M2[1:5, 4] <- 1L css2 <- structure(list(X = X2, y = y, feat_sel_mat = M2), class = "cssr") proto2 <- suppressWarnings( getSelectionPrototypes(css2, selected_clusts = list(c(3L, 4L)))) testthat::expect_identical(unname(proto2), 3L) }) testthat::test_that("getSelectionPrototypes skips the correlation tie-break for non-numeric y (#128)", { # css() accepts a non-numeric y (response validation is delegated to fitfun), # so getSelectionPrototypes must NOT call cor() -- which requires a numeric y -- # when breaking a selection-proportion tie. Hand-build a cssr object with a # CHARACTER y and a feat_sel_mat in which members 1 and 2 tie (equal column # means) so the tie block IS entered (length(proto_i) > 1). Without the # is.numeric(y) guard, cor(X[, 1:2], <character y>) would error; the guard skips # it and the first tied index is returned deterministically. B <- 10L; p <- 2L; n <- 8L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- paste0("V", 1:p) y <- letters[1:n] # non-numeric (character) response M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5, M[1:5, 2] <- 1L # forcing the tie-break path css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # suppressWarnings: an unbroken length-2 tie triggers a benign R "number of # items to replace" warning at the names-assignment (it fires for ANY persisted # tie, incl. the numeric #68 case) that would otherwise fail testthat edition 3. res <- suppressWarnings(getSelectionPrototypes(css, list(c(1L, 2L)))) testthat::expect_identical(unname(res), 1L) # first tied index, deterministic }) testthat::test_that("getSelectionPrototypes emits no warning on an unbroken tie (#126)", { # Item-5 regression (#126): the name-assignment now indexes proto_i[1] (a single # element), not the possibly length>1 proto_i. On an UNBROKEN within-cluster tie # -- here a CHARACTER y, so the numeric correlation tie-break is skipped and # proto_i stays length 2 -- the pre-fix code raised R's "number of items to # replace is not a multiple of replacement length" warning at the names<- # assignment (surfacing through print.cssr / summary.cssr / printCssDf). After # the fix NO warning fires, and the returned prototype is still the first tied # index (value unchanged; only the spurious warning is removed). B <- 10L; p <- 2L; n <- 8L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- paste0("V", 1:p) y <- letters[1:n] # non-numeric (character) response M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5, M[1:5, 2] <- 1L # forcing the (unbroken) tie-break path css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # No suppressWarnings here: the fix must make this call warning-free. testthat::expect_no_warning( res <- getSelectionPrototypes(css, list(c(1L, 2L)))) testthat::expect_identical(unname(res), 1L) # first tied index, deterministic testthat::expect_identical(names(res), "V1") # name taken from proto_i[1] only }) ## Test passed with 17 successes. ## Test passed with 3 successes. ## Test passed with 1 success. ## Test passed with 3 successes. Tests for printCssDf(): testthat::test_that("printCssDf works", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10) ret <- printCssDf(css_results) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_true(all(names(good_clusters) %in% ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) # Try again naming features x_named <- x colnames(x_named) <- LETTERS[1:11] css_results_name_feats <- css(X=x_named, y=y, lambda=0.01, clusters=good_clusters, B=10) ret <- printCssDf(css_results_name_feats) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_true(all(names(good_clusters) %in% ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.character(ret$ClustProtoName)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoName"] %in% LETTERS[1:3]) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoName"] %in% LETTERS[4:6]) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoName"] %in% LETTERS[7:11])) testthat::expect_true(length(ret[other_rows, "ClustProtoName"]) == length(unique(ret[other_rows, "ClustProtoName"]))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) # Unnamed clusters unnamed_clusters <- list(1:3, 4:6) css_results_unnamed <- css(X=x, y=y, lambda=0.01, clusters=unnamed_clusters, B=10) ret <- printCssDf(css_results_unnamed) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) # Try other settings for cutoff, min_num_clusts, max_num_clusts, etc. ret <- printCssDf(css_results, max_num_clusts=3) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) testthat::expect_true(nrow(ret) <= 3) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } ret <- printCssDf(css_results, min_num_clusts=2, cutoff=1) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_true(nrow(ret) >= 2) testthat::expect_true(nrow(ret) <= 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } # ret <- printCssDf(css_results, cutoff=1) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) testthat::expect_true(nrow(ret) >= 1) testthat::expect_true(nrow(ret) <= 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } ## Trying bad inputs # Error has quotation marks in it testthat::expect_error(printCssDf("css_results")) testthat::expect_error(printCssDf(css_results, cutoff=-.1), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(printCssDf(css_results, min_num_clusts=3.2), "min_num_clusts == round(min_num_clusts) is not TRUE", fixed=TRUE) testthat::expect_error(printCssDf(css_results, max_num_clusts="5"), "is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE", fixed=TRUE) }) ## Test passed with 98 successes. Tests for print.cssr() (and a minimal-B smoke test for css()): testthat::test_that("print.cssr 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) # print() dispatches to print.cssr, which returns its argument invisibly (the # standard print-method convention; see print.cssr's @return / #16). testthat::expect_invisible(print(css_res)) ret <- print(css_res) testthat::expect_identical(ret, css_res) # It prints the printCssDf summary table (column headers included). testthat::expect_output(print(css_res), "ClustName") testthat::expect_output(print(css_res), "ClustSize") # max_num_clusts routes through to printCssDf (at most that many cluster rows). out_all <- utils::capture.output(print(css_res)) out_one <- utils::capture.output(print(css_res, max_num_clusts=1)) testthat::expect_true(length(out_one) <= length(out_all)) }) testthat::test_that("css runs with B = 1 (minimal subsampling)", { 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) # B = 1 is allowed (checkB requires only B > 0) but warns that small B is poor. testthat::expect_warning( css_b1 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 1), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_true(inherits(css_b1, "cssr")) # The minimal-B object is still well-formed downstream. sel <- getCssSelections(css_b1) testthat::expect_identical(names(sel), c("selected_clusts", "selected_feats", "weights")) }) ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 banana 4 1.00 2 ## 2 cantaloupe 5 0.80 1 ## 3 c4 6 0.60 1 ## 4 apple 1 0.55 2 ## 5 c5 7 0.30 1 ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 banana 4 1.00 2 ## 2 cantaloupe 5 0.80 1 ## 3 c4 6 0.60 1 ## 4 apple 1 0.55 2 ## 5 c5 7 0.30 1 ## Test passed with 5 successes. ## Test passed with 3 successes. Tests for selected() / selected.cssr(): testthat::test_that("selected.cssr returns clusters and features", { 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) ref <- getCssSelections(css_res) # type = "clusters" (the default): a named list of integer vectors, identical # to getCssSelections()$selected_clusts at the same parameters. clusts <- selected(css_res) testthat::expect_true(is.list(clusts)) testthat::expect_identical(clusts, ref$selected_clusts) testthat::expect_identical(selected(css_res, type="clusters"), ref$selected_clusts) # type = "features": a flat integer vector, identical to # getCssSelections()$selected_feats. feats <- selected(css_res, type="features") testthat::expect_true(is.integer(feats)) testthat::expect_identical(feats, ref$selected_feats) # S3 dispatch: selected(obj) reaches selected.cssr(). testthat::expect_identical(selected(css_res), selected.cssr(css_res)) # Consistency with getCssSelections() at a nondefault cutoff and weighting # (features path). ref2 <- getCssSelections(css_res, weighting="simple_avg", cutoff=0.3) testthat::expect_identical( selected(css_res, type="features", weighting="simple_avg", cutoff=0.3), ref2$selected_feats) # Invalid inputs are rejected via the reused checks (checkCutoff / # checkWeighting), same messages as getCssSelections(). testthat::expect_error(selected(css_res, cutoff=-0.5), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(selected(css_res, weighting="spasre"), "Weighting must be a character and one of sparse, simple_avg, or weighted_avg", fixed=TRUE) }) testthat::test_that("selected(type='clusters') is invariant to weighting", { 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) # weighting only affects individual-feature weights, never which clusters are # selected: the type = "clusters" output is identical across weighting values. sparse <- selected(css_res, type="clusters", weighting="sparse", cutoff=0.2) wavg <- selected(css_res, type="clusters", weighting="weighted_avg", cutoff=0.2) savg <- selected(css_res, type="clusters", weighting="simple_avg", cutoff=0.2) testthat::expect_identical(sparse, wavg) testthat::expect_identical(sparse, savg) # By contrast the features path CAN depend on weighting: "simple_avg" returns # every member of the selected clusters, so at least as many as "sparse". feats_sparse <- selected(css_res, type="features", weighting="sparse", cutoff=0.2) feats_savg <- selected(css_res, type="features", weighting="simple_avg", cutoff=0.2) testthat::expect_true(length(feats_savg) >= length(feats_sparse)) }) ## Test passed with 9 successes. ## Test passed with 3 successes. Tests for summary.cssr() / print.summary.cssr(): testthat::test_that("summary.cssr summarizes clusters, sizes, and header counts", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10) smry <- summary(css_res) testthat::expect_true(inherits(smry, "summary.cssr")) ref <- getCssSelections(css_res) ref_df <- printCssDf(css_res) # Header counts are consistent with getCssSelections(). testthat::expect_equal(smry$n_selected_clusts, length(ref$selected_clusts)) testthat::expect_equal(smry$n_selected_feats, length(ref$selected_feats)) testthat::expect_equal(smry$cutoff, 0) # The per-cluster table IS printCssDf()'s data.frame (Theta-hat = ClustSelProp, # plus ClustSize), so clusters / proportions / sizes all match. testthat::expect_identical(smry$table, ref_df) testthat::expect_equal(nrow(smry$table), 7) testthat::expect_equal(smry$n_selected_clusts, nrow(smry$table)) testthat::expect_true(all(c("ClustName", "ClustSelProp", "ClustSize") %in% colnames(smry$table))) testthat::expect_equal(smry$table[smry$table$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(smry$table[smry$table$ClustName=="green_cluster", "ClustSize"], 3) # PFER placeholder present (to be filled in by #87). testthat::expect_true("pfer" %in% names(smry)) testthat::expect_true(is.na(smry$pfer)) # print.summary.cssr runs, prints the header + table, returns x invisibly. testthat::expect_invisible(print(smry)) ret <- print(smry) testthat::expect_identical(ret, smry) testthat::expect_output(print(smry), "selected at cutoff") testthat::expect_output(print(smry), "ClustName") # S3 dispatch: summary(obj) reaches summary.cssr(). testthat::expect_identical(summary(css_res), summary.cssr(css_res)) # Invalid cutoff rejected via the reused check. testthat::expect_error(summary(css_res, cutoff=1.5), "cutoff <= 1 is not TRUE", fixed=TRUE) }) ## Cluster stability selection summary ## 7 clusters / 7 features selected at cutoff 0 ## ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 red_cluster 1 1.00 3 ## 2 c3 7 1.00 1 ## 3 green_cluster 6 0.80 3 ## 4 c7 11 0.70 1 ## 5 c6 10 0.65 1 ## 6 c4 8 0.60 1 ## 7 c5 9 0.40 1 ## ## PFER: NA (not yet implemented; see issue #87) ## Cluster stability selection summary ## 7 clusters / 7 features selected at cutoff 0 ## ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 red_cluster 1 1.00 3 ## 2 c3 7 1.00 1 ## 3 green_cluster 6 0.80 3 ## 4 c7 11 0.70 1 ## 5 c6 10 0.65 1 ## 6 c4 8 0.60 1 ## 7 c5 9 0.40 1 ## ## PFER: NA (not yet implemented; see issue #87) ## Test passed with 18 successes. Test for the empty-selection path of the print layer (issues #107 and #120). Post-#107 an empty selection is valid; #120 makes printCssDf(), print.cssr(), and getSelectionPrototypes() return clean empty output – a zero-row data.frame, a “(no clusters selected …)” message, and an empty integer vector, respectively – via an early return before the nrow >= 1 / n_selected_clusts >= 1 guards, rather than tripping those assertions. The block also covers the higher-level selected() and a zero-row summary.cssr(). testthat::test_that("selected() and summary() handle an empty selection", { # Same empty-producing fixture as the getCssSelections #107 test: fixed seed, # all-singleton clusters, and a large lambda so the base lasso selects almost # nothing; cutoff = 1 with min_num_clusts = 0 then selects no cluster. 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)) # selected(): a clean empty list / empty integer vector, no error. empty_clusts <- selected(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(is.list(empty_clusts)) testthat::expect_length(empty_clusts, 0) empty_feats <- selected(css_res, type="features", cutoff=1, min_num_clusts=0) testthat::expect_true(is.integer(empty_feats)) testthat::expect_length(empty_feats, 0) # summary(): a well-formed zero-row summary (table NULL, "0 clusters" header), # NOT an opaque stopifnot() failure from printCssDf/getSelectionPrototypes. smry <- summary(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(inherits(smry, "summary.cssr")) testthat::expect_equal(smry$n_selected_clusts, 0) testthat::expect_equal(smry$n_selected_feats, 0) testthat::expect_true(is.null(smry$table)) # print still works and reports 0 clusters / 0 features. testthat::expect_invisible(print(smry)) testthat::expect_output(print(smry), "0 clusters / 0 features") # printCssDf() (#120): an empty selection returns a well-formed zero-row # data.frame with the SAME columns as a non-empty printCssDf() on the same # object, rather than tripping stopifnot(nrow >= 1). Unnamed X (this fixture) # -> 4 columns, no ClustProtoName. empty_df <- printCssDf(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(is.data.frame(empty_df)) testthat::expect_equal(nrow(empty_df), 0) testthat::expect_equal(ncol(empty_df), 4) nonempty_df <- printCssDf(css_res, cutoff=0) testthat::expect_true(nrow(nonempty_df) >= 1) # The invariant that matters: empty and non-empty share the same column set. testthat::expect_identical(colnames(empty_df), colnames(nonempty_df)) testthat::expect_identical( colnames(empty_df), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Correct 0-length column types. testthat::expect_true(is.character(empty_df$ClustName)) testthat::expect_true(is.integer(empty_df$ClustProtoNum)) testthat::expect_true(is.numeric(empty_df$ClustSelProp)) testthat::expect_true(is.integer(empty_df$ClustSize)) # Named X -> the 5-column path (adds ClustProtoName). Same data + column names, # so the selection is still empty at cutoff = 1 with min_num_clusts = 0. x_named <- x colnames(x_named) <- paste0("V", seq_len(ncol(x_named))) css_named <- css(X=x_named, y=y, lambda=0.5, clusters=list(), B=B) empty_named_df <- printCssDf(css_named, cutoff=1, min_num_clusts=0) testthat::expect_true(is.data.frame(empty_named_df)) testthat::expect_equal(nrow(empty_named_df), 0) testthat::expect_equal(ncol(empty_named_df), 5) testthat::expect_true("ClustProtoName" %in% colnames(empty_named_df)) testthat::expect_identical(colnames(empty_named_df), colnames(printCssDf(css_named, cutoff=0))) # getSelectionPrototypes() on an empty list of clusters -> integer(0) (#120). testthat::expect_identical(getSelectionPrototypes(css_res, list()), integer(0)) # print.cssr() (#120): prints a "(no clusters selected ...)" message instead # of a table, does not error, and returns the cssr object invisibly unchanged. testthat::expect_output( ret <- print(css_res, cutoff=1, min_num_clusts=0), "no clusters selected") testthat::expect_identical(ret, css_res) testthat::expect_invisible(print(css_res, cutoff=1, min_num_clusts=0)) }) ## Cluster stability selection summary ## 0 clusters / 0 features selected at cutoff 1 ## (no clusters selected at this cutoff) ## ## PFER: NA (not yet implemented; see issue #87) ## (no clusters selected at cutoff 1) ## Test passed with 30 successes. Tests for plot.cssr(). All plotting is drawn to a null device (grDevices::pdf(NULL) / grDevices::dev.off()) so the tests produce no file or window. They cover the return value (the sorted selection proportions), the index-based feature highlight for an unnamed X (the B2 guard), ... passthrough to barplot() without a duplicate-argument crash (the B1 guard), and the empty-selection and single-cluster edge cases. testthat::test_that("plot.cssr draws cluster proportions and returns them sorted", { # Named X so the feature matrix (tested below) carries feature names. set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) grDevices::pdf(NULL) # draw to a null device (no file, no window) # (a) Clusters (default): runs without error and invisibly returns the sorted # named cluster selection proportions (a deterministic proof of the return). testthat::expect_invisible(plot(css_res)) ret <- plot(css_res) testthat::expect_equal(ret, sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE)) testthat::expect_false(is.null(names(ret))) # cluster names guaranteed # (b) Features, NAMED X: returns the sorted NAMED feature selection # proportions, and the (index-based) highlight matches getCssSelections(). ret_f <- plot(css_res, type="features") props_f <- colMeans(css_res$feat_sel_mat) testthat::expect_equal(ret_f, sort(props_f, decreasing=TRUE)) testthat::expect_identical(names(ret_f), paste0("V", order(props_f, decreasing=TRUE))) # named + correctly ordered sel_f <- getCssSelections(css_res, weighting="sparse") ord <- order(props_f, decreasing=TRUE) is_sel <- (seq_along(props_f) %in% as.integer(sel_f$selected_feats))[ord] testthat::expect_equal(sum(is_sel), length(sel_f$selected_feats)) testthat::expect_setequal(ord[is_sel], as.integer(sel_f$selected_feats)) grDevices::dev.off() }) testthat::test_that("plot.cssr feature highlight is index-based for unnamed X (B2)", { # genClusteredData returns X with NULL colnames -> feat_sel_mat is UNNAMED. # A name-based feature highlight would silently be all-FALSE; the method uses # an INDEX-based highlight, which must still be non-empty. This is the B2 # regression proof. set.seed(721) dat <- genClusteredData(n=60, p=11, k_unclustered=2, cluster_size=4, n_clusters=1, snr=3) clusters <- list(cluster1=1:4) css_res <- suppressWarnings(css(X=dat$X, y=dat$y, lambda=0.01, clusters=clusters, B=10)) # Precondition for the B2 guard: the feature matrix really is unnamed. testthat::expect_null(colnames(css_res$feat_sel_mat)) grDevices::pdf(NULL) props <- colMeans(css_res$feat_sel_mat) ret <- plot(css_res, type="features", cutoff=0.3) # Returns the plain (unnamed) sorted colMeans regardless of the cutoff. testthat::expect_equal(ret, sort(props, decreasing=TRUE)) testthat::expect_null(names(ret)) # Re-derive the highlight exactly as plot.cssr does: INDEX-based. sel <- getCssSelections(css_res, weighting="sparse", cutoff=0.3) testthat::expect_true(length(sel$selected_feats) > 0) # there ARE selections ord <- order(props, decreasing=TRUE) is_sel <- (seq_along(props) %in% as.integer(sel$selected_feats))[ord] testthat::expect_true(any(is_sel)) # NON-empty highlight testthat::expect_equal(sum(is_sel), length(sel$selected_feats)) # The highlighted bars are exactly the selected features, by ORIGINAL index. testthat::expect_setequal(ord[is_sel], as.integer(sel$selected_feats)) # Contrast: a NAME-based highlight WOULD have failed here (names are NULL, so # names(props) %in% ... is logical(0) -> no bar highlighted). testthat::expect_false(any(names(props) %in% as.character(sel$selected_feats))) grDevices::dev.off() }) testthat::test_that("plot.cssr forwards ... to barplot without a duplicate-arg crash (B1)", { # The method builds a SINGLE merged barplot arg list, so graphical params on # ... cannot collide with col/ylim/height (which previously crashed with # "formal argument 'col' matched by multiple actual arguments"). set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) grDevices::pdf(NULL) testthat::expect_no_error(plot(css_res, col="red")) testthat::expect_no_error(plot(css_res, ylim=c(0, 0.5))) testthat::expect_no_error(plot(css_res, main="x")) testthat::expect_no_error(plot(css_res, type="features", col="red", main="feats")) grDevices::dev.off() }) testthat::test_that("plot.cssr handles an empty selection and a single cluster", { # (e) Empty selection: min_num_clusts = 0 with a cutoff strictly above every # cluster proportion selects nothing (min_num_clusts = 1 is never empty). All # bars get unsel_col, there is no highlight, and there is no crash. 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) max_prop <- max(colMeans(css_res$clus_sel_mat)) testthat::expect_true(max_prop < 1) cut <- (max_prop + 1) / 2 # strictly between max_prop and 1 (and <= 1) sel <- getCssSelections(css_res, cutoff=cut, min_num_clusts=0) testthat::expect_length(sel$selected_clusts, 0) # genuinely empty grDevices::pdf(NULL) # A bare call that errored would fail the test -> this asserts "no crash". ret <- plot(css_res, min_num_clusts=0, cutoff=cut) testthat::expect_equal(ret, sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE)) grDevices::dev.off() # (f) Single-cluster css: clus_sel_mat has exactly one column -> a length-1 # barplot, no error. set.seed(1) x1 <- matrix(stats::rnorm(10*4), nrow=10, ncol=4) y1 <- stats::rnorm(10) css_1 <- css(X=x1, y=y1, lambda=0.01, clusters=list(all=1:4), B=10) testthat::expect_equal(ncol(css_1$clus_sel_mat), 1) grDevices::pdf(NULL) ret1 <- plot(css_1) testthat::expect_length(ret1, 1) grDevices::dev.off() }) testthat::test_that("plot.cssr surfaces the tie-breach warning (#159c)", { # plot.cssr no longer wraps getCssSelections in suppressWarnings, so a # max_num_clusts breach reaches the user. Two clusters tied at proportion 1.0 # with max_num_clusts = 1 cannot be reduced below 2 without emptying the # selection, so checkSelectedClusters warns. Pre-#159c the blanket # suppressWarnings swallowed it, so this test FAILS on the old code. B <- 10 clusters <- list(c1 = 1L, c2 = 2L) clus_sel_mat <- cbind(c1 = rep(1L, B), c2 = rep(1L, B)) feat_sel_mat <- cbind(f1 = rep(1L, B), f2 = rep(1L, B)) obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat, clusters = clusters), class = "cssr") grDevices::pdf(NULL) # draw to a null device (no file, no window) on.exit(grDevices::dev.off(), add = TRUE) testthat::expect_warning(plot(obj, max_num_clusts = 1), "Returning more than max_num_clusts", fixed = TRUE) }) ## Test passed with 7 successes. ## Test passed with 8 successes. ## Test passed with 4 successes. ## Test passed with 5 successes. ## Test passed with 1 success. Two further tests pin down the issue #160 fixes. Both mock the graphics drawing primitives with testthat::with_mocked_bindings() so they can assert on the arguments the method actually passes to them. The first checks that a user-supplied col in ... now reaches barplot() verbatim – and that, with no col, the method’s own highlight colors still apply. The second checks that the dashed cutoff line is drawn only for type = \"clusters\" (whose axis matches the highlight) and never for type = \"features\". testthat::test_that("plot.cssr honors a user col in ... and otherwise applies the highlight (#160a)", { set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) # barplot is mocked (nothing is drawn) and cutoff = 0 (no abline), so no real # graphics call is made; the device is opened only defensively. grDevices::pdf(NULL) on.exit(grDevices::dev.off(), add=TRUE) # (a1) A user col in ... must reach barplot() verbatim. Before #160a the method # overwrote it with the highlight colors (this asserted "red" but got # steelblue/grey70). captured <- NULL testthat::with_mocked_bindings( barplot = function(...) captured <<- list(...), plot(css_res, col="red"), .package = "graphics" ) testthat::expect_identical(captured$col, "red") # (a2) With no col the method's own highlight must STILL apply -- guards against # over-fixing (a1) by dropping the default. max_num_clusts=2 forces a genuine # mix (>=1 selected, >=1 unselected) so both ifelse branches are exercised. captured2 <- NULL testthat::with_mocked_bindings( barplot = function(...) captured2 <<- list(...), plot(css_res, max_num_clusts=2), .package = "graphics" ) props <- colMeans(css_res$clus_sel_mat) sel <- suppressWarnings(getCssSelections(css_res, weighting="sparse", cutoff=0, min_num_clusts=1, max_num_clusts=2)) is_sel <- (names(props) %in% names(sel$selected_clusts))[order(props, decreasing=TRUE)] testthat::expect_identical(captured2$col, ifelse(is_sel, "steelblue", "grey70")) testthat::expect_true("steelblue" %in% captured2$col) # a genuine mix, so both testthat::expect_true("grey70" %in% captured2$col) # branches are covered }) testthat::test_that("plot.cssr draws the cutoff line only for type='clusters' (#160b)", { set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) # Real barplot draws to a null device; only abline is mocked (a flag/capture). grDevices::pdf(NULL) on.exit(grDevices::dev.off(), add=TRUE) # (b1) type="features": the line would sit on the feature-proportion axis while # highlighting follows cluster selection, so no reference line is drawn (#160b). called <- FALSE testthat::with_mocked_bindings( abline = function(...) called <<- TRUE, plot(css_res, type="features", cutoff=0.6), .package = "graphics" ) testthat::expect_false(called) # (b2) type="clusters": the line's axis matches the highlight, so it IS drawn at # h = cutoff. called <- FALSE ab_args <- NULL testthat::with_mocked_bindings( abline = function(...) { called <<- TRUE; ab_args <<- list(...) }, plot(css_res, type="clusters", cutoff=0.6), .package = "graphics" ) testthat::expect_true(called) testthat::expect_equal(ab_args$h, 0.6) # (b3) cutoff=0: no line in either mode (unchanged behavior). called <- FALSE testthat::with_mocked_bindings( abline = function(...) called <<- TRUE, plot(css_res, type="clusters", cutoff=0), .package = "graphics" ) testthat::expect_false(called) }) ## Test passed with 4 successes. ## Test passed with 4 successes. Byte-identity tests for the issue #129 performance micro-optimizations. Each asserts that the de-duplicated / hoisted path returns a value identical to the recomputed path it replaced. Per issue #129 these compare RETURN VALUES (wrapped in suppressWarnings), never warning counts: Opts 2 and 3 intentionally collapse repeated getSelectedClusters() calls, which only de-duplicates a warning side-channel and leaves the returned objects unchanged. testthat::test_that("Opt 2 (#129): formCssDesign weights= equals internal recompute; getCssPreds finite", { set.seed(721) dat <- genClusteredData(n = 60, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) clusters <- list(cluster1 = 1:4) res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 15)) # The hoist: passing weights= (as getCssPreds now does) must build a design # matrix byte-identical to letting formCssDesign() recompute the weights via # getSelectedClusters(), across every weighting rule. for(w in c("sparse", "weighted_avg", "simple_avg")){ wts <- getSelectedClusters(res, w, 0, 1, NA)$weights d_recompute <- suppressWarnings(formCssDesign(res, weighting = w, newx = dat$X)) d_passed <- suppressWarnings(formCssDesign(res, weighting = w, newx = dat$X, weights = wts)) testthat::expect_identical(d_passed, d_recompute) } # End-to-end getCssPreds still returns finite predictions of the right length # for both the provided-trainX path and the train_inds path, across weightings. res_ti <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 15, train_inds = 41:60)) for(w in c("sparse", "weighted_avg", "simple_avg")){ p_prov <- suppressWarnings(getCssPreds(res, testX = dat$X[1:10, ], trainX = dat$X[11:40, ], trainY = dat$y[11:40], weighting = w)) testthat::expect_length(p_prov, 10) testthat::expect_true(all(is.finite(p_prov))) p_ti <- suppressWarnings(getCssPreds(res_ti, testX = dat$X[1:10, ], weighting = w)) testthat::expect_length(p_ti, 10) testthat::expect_true(all(is.finite(p_ti))) } }) testthat::test_that("Opt 3 (#129): buildCssDf equals printCssDf; summary$table reuses it", { set.seed(824) dat <- genClusteredData(n = 55, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) clusters <- list(cluster1 = 1:4) res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 12)) # buildCssDf(obj, getCssSelections(obj, ...)$selected_clusts) reproduces # printCssDf(obj, ...) exactly, across cutoffs (including the empty selection # at cutoff = 1 with min_num_clusts = 0). for(cut in c(0, 0.2, 0.5, 1)){ sc <- suppressWarnings(getCssSelections(res, cutoff = cut, min_num_clusts = 0))$selected_clusts testthat::expect_identical( suppressWarnings(buildCssDf(res, sc)), suppressWarnings(printCssDf(res, cutoff = cut, min_num_clusts = 0))) } # summary.cssr()$table (now built via buildCssDf() on summary's own # sel$selected_clusts) equals printCssDf() on the same object across # weightings -- cluster selection is weighting-invariant, so reusing summary's # sel$selected_clusts is byte-identical to printCssDf's internal recompute. ref <- suppressWarnings(printCssDf(res)) for(w in c("sparse", "weighted_avg", "simple_avg")){ s <- suppressWarnings(summary(res, weighting = w)) testthat::expect_identical(s$table, ref) } }) ## Test passed with 15 successes. ## Test passed with 7 successes. "],["tests-for-wrapper-functions.html", "11 Tests for wrapper functions", " 11 Tests for wrapper functions Tests for cssSelect(): testthat::test_that("cssSelect works", { set.seed(73212) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1) x <- data$X y <- data$y # Intentionally don't provide clusters for all features, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:3L, 4:6) res <- cssSelect(X=x, y=y, clusters=good_clusters) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_true(length(res$selected_clusts) <= 7) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # No provided clusters res <- cssSelect(X=x, y=y) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) testthat::expect_true(length(res$selected_clusts) <= 11) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars # cssSelect() reports a max_num_clusts tie on this draw. It is not asserted, # because whether the tie occurs depends on the estimated model size and so # on glmnet's lasso path rather than on cssr; the warning has deterministic # coverage in "checkSelectedClusters works" and in the #159c plot.cssr test. # Muffling just that one message leaves every other warning visible (#186). res <- withCallingHandlers( cssSelect(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of ncol(X_df) - (3 - 1) clusters testthat::expect_true(length(res$selected_clusts) <= ncol(X_df) - 2) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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:ncol(X_df))) 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) <= ncol(X_df)) testthat::expect_equal(length(already_used_feats), length(unique(already_used_feats))) testthat::expect_true(all(already_used_feats %in% 1:ncol(X_df))) testthat::expect_true(length(res$selected_feats) <= ncol(X_df)) 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 <= ncol(X_df))) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if I try to use data.frame with clusters, since data.frame # has factors with more than two levels testthat::expect_error(cssSelect(X=df2, y=stats::rnorm(nrow(X_df)), clusters=1:3), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert the data.frame X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if I don't use clusters res <- cssSelect(X=df2, y=stats::rnorm(nrow(X_df))) X_df_mat <- stats::model.matrix(~ ., df2) X_df_mat <- X_df_mat[, colnames(X_df_mat) != "(Intercept)"] p <- ncol(X_df_mat) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of p - (3 - 1) clusters testthat::expect_true(length(res$selected_clusts) <= p - 2) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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:p)) 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) <= p) testthat::expect_equal(length(already_used_feats), length(unique(already_used_feats))) testthat::expect_true(all(already_used_feats %in% 1:p)) testthat::expect_true(length(res$selected_feats) <= p) 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 <= p)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] res <- cssSelect(X=x2, y=y, clusters=good_clusters) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_true(length(res$selected_clusts) <= 7) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # Vary inputs res <- cssSelect(X=x, y=y, clusters=good_clusters, lambda=0.01) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) res <- cssSelect(X=x, y=y, clusters=good_clusters, cutoff=0.6) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) res <- cssSelect(X=x, y=y, clusters=good_clusters, max_num_clusts=6) 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) <= 6) res <- cssSelect(X=x, y=y, clusters=good_clusters, auto_select_size=FALSE) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_equal(length(res$selected_clusts), 7) # Bad inputs testthat::expect_error(cssSelect(X=x[1:10, ], y=y), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=character(5), y=y), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=matrix(1:15, 5, 3)), "!is.matrix(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=factor(rbinom(15, size=1, prob=.5))), "The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, clusters="clusters"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, lambda=-.1), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, cutoff=1.1), "cutoff <= 1 is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, max_num_clusts=1000), "max_num_clusts <= p is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, auto_select_size=1), "is.logical(auto_select_size) is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(cssSelect(X=x, y=y, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(cssSelect(X=x, y=y, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) # alpha = NA is rejected with a clear message (rather than a cryptic error # deep inside the bundling/subsampling logic). A bare (logical) NA trips the # type check first; a numeric NA reaches the dedicated !is.na guard. testthat::expect_error(cssSelect(X=x, y=y, alpha=NA), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, alpha=NA_real_), "!is.na(alpha) is not TRUE", fixed=TRUE) # An NA in the design matrix yields the shared friendly message (#56). x_na <- x; x_na[2, 1] <- NA testthat::expect_error(cssSelect(X=x_na, y=y), "must not contain missing", fixed=TRUE) # (#127) A single-column X reaches getLassoLambda as a matrix and now errors # with the clean "p >= 2 is not TRUE" message rather than a cryptic downstream # failure ("invalid 'times' argument"). testthat::expect_error( cssSelect(matrix(stats::rnorm(40), nrow=40, ncol=1), stats::rnorm(40)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 220 successes. Tests confirming that a non-default alpha is threaded through cssSelect() end-to-end and changes the selected set on a correlated-block design (this is the wrapper-level analogue of the cssLasso headline test; it is new behavior absent on main, where alpha could not affect selection): testthat::test_that("cssSelect threads alpha through to selection", { set.seed(1) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), n, p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) # Treat the correlated block as one cluster; the remaining features are # singletons. Fix lambda and the model size so the only thing that varies # between the two calls is alpha. clusters <- list(block=1:block) res_lasso <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251, max_num_clusts=p - block + 1, alpha=1) res_enet <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251, max_num_clusts=p - block + 1, alpha=0.5) # Both return a well-formed selection for(res in list(res_lasso, res_enet)){ testthat::expect_true(is.list(res)) testthat::expect_true(all(c("selected_clusts", "selected_feats") %in% names(res))) testthat::expect_true(is.integer(res$selected_feats)) testthat::expect_true(all(res$selected_feats %in% 1:p)) } # The elastic net selects (weakly) more features than the pure lasso on this # correlated design, and the two selected sets differ. testthat::expect_true(length(res_enet$selected_feats) >= length(res_lasso$selected_feats)) testthat::expect_false(setequal(res_enet$selected_feats, res_lasso$selected_feats)) }) ## Test passed with 10 successes. Tests for cssPredict(): testthat::test_that("cssPredict works", { set.seed(84231) train_data <- genClusteredData(n=30, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1) x <- train_data$X y <- train_data$y test_x <- genClusteredData(n=5, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1)$X # Intentionally don't provide clusters for all features, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:3L, 4:6) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters=good_clusters) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # No provided clusters res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Provide training indices res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, train_inds=13:28) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars n <- nrow(X_df) test_inds <- 1:round(n/3) n_test <- length(test_inds) selec_train_inds <- setdiff(1:n, test_inds) n_selec_train <- length(selec_train_inds) res <- cssPredict(X_train_selec=X_df[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=X_df[test_inds, ]) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), n_test) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if clusters are provided because df2 contains factors with # more than two levels testthat::expect_error(cssPredict(X_train_selec=df2[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=df2[test_inds, ], clusters=1:3), "When stats::model.matrix converted the provided data.frame X_train_selec to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X_train_selec to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- cssPredict(X_train_selec=df2[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=df2[test_inds, ]) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), n_test) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] test_x2 <- test_x colnames(test_x2) <- LETTERS[1:11] res <- cssPredict(X_train_selec=x2, y_train_selec=y, X_test=test_x2, clusters=good_clusters) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Vary inputs res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, lambda=0.01) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=0.6) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, max_num_clusts=6) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, auto_select_size=FALSE) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Non-default alpha (elastic net) threaded through end-to-end; smoke test # confirming it returns a well-formed prediction vector of the right length. res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=0.5) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Bad inputs testthat::expect_error(cssPredict(X_train_selec=x[1:10, ], y_train_selec=y, X_test=test_x), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=character(30), y_train_selec=y, X_test=test_x), "is.matrix(X_train_selec) | is.data.frame(X_train_selec) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=matrix(1:30, 10, 3), X_test=test_x), "!is.matrix(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=factor(rbinom(30, size=1, prob=.5)), X_test=test_x), "The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters="clusters"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, lambda="lambda"), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=-.1), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, max_num_clusts=0), "max_num_clusts >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, auto_select_size=c(TRUE, FALSE)), "length(auto_select_size) == 1 is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) # (#127) A single-column training design now reaches getLassoLambda as a matrix # (drop = FALSE on the subsample) and errors with the clean "p >= 2 is not # TRUE" message rather than "is.matrix(X) is not TRUE". testthat::expect_error( cssPredict(X_train_selec=matrix(stats::rnorm(40), nrow=40, ncol=1), y_train_selec=stats::rnorm(40), X_test=matrix(stats::rnorm(10), nrow=10, ncol=1)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 46 successes. A length-1 train_inds used to collapse X_train_selec[train_inds, ] to a vector, tripping getModelSize’s cryptic is.matrix(X) | is.data.frame(X) assertion. With drop = FALSE it stays a one-row matrix and the error instead points informatively at the data (issue #153, item f). testthat::test_that("cssPredict: length-1 train_inds no longer hits the cryptic is.matrix assertion (#153f)", { 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) # A length-1 train_inds leaves a single training row, so getModelSize's glmnet # cross-validation fails informatively on a constant response -- NOT with the # old cryptic is.matrix stopifnot from the dropped-to-vector subset. Warnings # (e.g. glmnet convergence) are suppressed so we assert on the stop() message. err <- tryCatch( suppressWarnings( cssPredict(X_train_selec = X[1:20, ], y_train_selec = y[1:20], X_test = X[41:60, ], clusters = clusters, lambda = 0.01, train_inds = 1L)), error = function(e) conditionMessage(e)) testthat::expect_type(err, "character") testthat::expect_true( grepl("y is constant; gaussian glmnet fails at standardization step", err, fixed = TRUE)) testthat::expect_false( grepl("is.matrix(X) | is.data.frame(X) is not TRUE", err, fixed = TRUE)) }) ## Test passed with 3 successes. "],["tests-for-competitor-methods.html", "12 Tests for competitor methods", " 12 Tests for competitor methods Tests for processClusterLassoInputs(): testthat::test_that("processClusterLassoInputs works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) ret <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("x", "clusters", "prototypes", "var_names")) # X testthat::expect_true(is.matrix(ret$x)) testthat::expect_true(all(!is.na(ret$x))) testthat::expect_true(is.numeric(ret$x)) testthat::expect_equal(ncol(ret$x), 11) testthat::expect_equal(nrow(ret$x), 15) testthat::expect_true(all(abs(ret$x - x) < 10^(-9))) # clusters testthat::expect_true(is.list(ret$clusters)) testthat::expect_equal(length(ret$clusters), 5) testthat::expect_equal(5, length(names(ret$clusters))) testthat::expect_equal(5, length(unique(names(ret$clusters)))) testthat::expect_true("red_cluster" %in% names(ret$clusters)) testthat::expect_true("green_cluster" %in% names(ret$clusters)) testthat::expect_true(all(!is.na(names(ret$clusters)))) testthat::expect_true(all(!is.null(names(ret$clusters)))) testthat::expect_true(all(names(ret$clusters) != "")) clust_feats <- integer() true_list <- list(1:4, 5:8, 9, 10, 11) for(i in 1:length(ret$clusters)){ testthat::expect_true(is.integer(ret$clusters[[i]])) testthat::expect_equal(length(intersect(clust_feats, ret$clusters[[i]])), 0) testthat::expect_true(all(ret$clusters[[i]] %in% 1:11)) testthat::expect_equal(length(ret$clusters[[i]]), length(unique(ret$clusters[[i]]))) testthat::expect_true(all(ret$clusters[[i]] == true_list[[i]])) clust_feats <- c(clust_feats, ret$clusters[[i]]) } testthat::expect_equal(length(clust_feats), 11) testthat::expect_equal(11, length(unique(clust_feats))) testthat::expect_equal(11, length(intersect(clust_feats, 1:11))) # prototypes testthat::expect_true(is.integer(ret$prototypes)) testthat::expect_true(all(ret$prototypes %in% 1:11)) testthat::expect_equal(length(ret$prototypes), 5) testthat::expect_true(ret$prototypes[1] %in% 1:4) testthat::expect_true(ret$prototypes[2] %in% 5:8) testthat::expect_equal(ret$prototypes[3], 9) testthat::expect_equal(ret$prototypes[4], 10) testthat::expect_equal(ret$prototypes[5], 11) # var_names testthat::expect_equal(length(ret$var_names), 1) testthat::expect_true(is.na(ret$var_names)) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("x", "clusters", "prototypes", "var_names")) X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # X testthat::expect_true(is.matrix(res$x)) testthat::expect_true(all(!is.na(res$x))) testthat::expect_true(is.numeric(res$x)) testthat::expect_equal(ncol(res$x), ncol(X_df_model)) testthat::expect_equal(nrow(res$x), nrow(X_df)) testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9))) # var_names testthat::expect_equal(length(res$var_names), ncol(X_df_model)) testthat::expect_true(is.character(res$var_names)) testthat::expect_identical(res$var_names, colnames(X_df_model)) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if I try to use clusters because df2 contains factors with # more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine with no clusters res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("x", "clusters", "prototypes", "var_names")) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # X testthat::expect_true(is.matrix(res$x)) testthat::expect_true(all(!is.na(res$x))) testthat::expect_true(is.numeric(res$x)) testthat::expect_equal(ncol(res$x), ncol(X_df_model)) testthat::expect_equal(nrow(res$x), nrow(X_df)) testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9))) # var_names testthat::expect_equal(length(res$var_names), ncol(X_df_model)) testthat::expect_true(is.character(res$var_names)) testthat::expect_identical(res$var_names, colnames(X_df_model)) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("x", "clusters", "prototypes", "var_names")) # X testthat::expect_true(is.matrix(ret$x)) testthat::expect_true(all(!is.na(ret$x))) testthat::expect_true(is.numeric(ret$x)) testthat::expect_equal(ncol(ret$x), 11) testthat::expect_equal(nrow(ret$x), 15) testthat::expect_true(all(abs(ret$x - x) < 10^(-9))) # var_names testthat::expect_equal(length(ret$var_names), ncol(x2)) testthat::expect_true(is.character(ret$var_names)) testthat::expect_identical(ret$var_names, LETTERS[1:11]) # Bad inputs testthat::expect_error(processClusterLassoInputs(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): identical to passing the # cluster once (processClusterLassoInputs is deterministic here). testthat::expect_identical(processClusterLassoInputs(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10), processClusterLassoInputs(X=x, y=y, clusters=list(2:3), nlambda=10)) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) }) ## Test passed with 99 successes. Tests for checkGetXglmnetInputs(): testthat::test_that("checkGetXglmnetInputs works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get an error if clusters are provided since df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) checkGetXglmnetInputs(x=ret$x, clusters=ret$clusters, type="clusterRepLasso", prototypes=ret$prototypes) # Bad prototype inputs # Error has quotation marks testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="clsterRepLasso", prototypes=process$prototypes)) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=c("clusterRepLasso", "protolasso"), prototypes=process$prototypes), "length(type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=2, prototypes=process$prototypes), "is.character(type) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=as.character(NA), prototypes=process$prototypes), "!is.na(type) is not TRUE", fixed=TRUE) }) ## Test passed with 5 successes. Tests for getXglmnet(): testthat::test_that("getXglmnet works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) res <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the prototypes. Features 9 - 11 are # in clusters by themselves and are therefore their own prototypes. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ proto_i_found <- FALSE cluster_i <- good_clusters[[i]] for(j in 1:length(cluster_i)){ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) < 10^(-9)) } testthat::expect_true(proto_i_found) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) res <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the cluster representatives. Features 9 # - 11 are in clusters by themselves and are therefore their own cluster # representatives. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ cluster_i <- good_clusters[[i]] clus_rep_i <- rowMeans(x[, cluster_i]) testthat::expect_true(all(abs(res[, i] - clus_rep_i) < 10^(-9))) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1) proto_found <- FALSE for(j in 1:3){ proto_found <- proto_found | all(abs(ret_df[, 1] - X_df_model[, j]) < 10^(-9)) } testthat::expect_true(proto_found) for(j in 4:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9))) } ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1) proto_found <- FALSE clus_rep <- rowMeans(X_df_model[, 1:3]) testthat::expect_true(all(abs(ret_df[, 1] - clus_rep) < 10^(-9))) for(j in 4:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9))) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model)) for(j in 1:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9))) } ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model)) for(j in 1:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9))) } # X as a matrix with column names (returned X shouldn't have column names) x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) res <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the prototypes. Features 9 - 11 are # in clusters by themselves and are therefore their own prototypes. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ proto_i_found <- FALSE cluster_i <- good_clusters[[i]] for(j in 1:length(cluster_i)){ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) < 10^(-9)) } testthat::expect_true(proto_i_found) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) res <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the cluster representatives. Features 9 # - 11 are in clusters by themselves and are therefore their own cluster # representatives. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ cluster_i <- good_clusters[[i]] clus_rep_i <- rowMeans(x[, cluster_i]) testthat::expect_true(all(abs(res[, i] - clus_rep_i) < 10^(-9))) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) # Bad prototype inputs # Error has quotation marks testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type="clsterRepLasso", prototypes=process$prototypes)) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=c("clusterRepLasso", "protolasso"), prototypes=process$prototypes), "length(type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=2, prototypes=process$prototypes), "is.character(type) is not TRUE", fixed=TRUE) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=as.character(NA), prototypes=process$prototypes), "!is.na(type) is not TRUE", fixed=TRUE) # do.call(cbind) preserves integer storage of an integer x (#58) x_int <- matrix(1:12, nrow = 4, ncol = 3) int_clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L) res_int <- getXglmnet(x_int, int_clusters, type = "protolasso", prototypes = c(1L, 2L, 3L)) testthat::expect_true(is.integer(res_int)) }) ## Test passed with 117 successes. Tests for getSelectedSets(): testthat::test_that("getSelectedSets works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[5]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # Try again with cluster representative lasso X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[5]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)), clusters=1:3, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should throw an error if we assign clusters because df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=1:3, nlambda=100), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should throw an error if we assign clusters because df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=1:3, nlambda=100), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } }) ## Test passed with 80 successes. Tests for getClusterSelsFromGlmnet(): testthat::test_that("getClusterSelsFromGlmnet works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) # Deliberately the raw predict.glmnet idiom rather than clusterLassoCore()'s # normalisation (#190). These fixtures exercise the CONSUMER against the # installed glmnet, bypassing the boundary on purpose, which is what makes # them complementary to the mocked shape pins further below; copying the # normalisation in here would defeat that. # # The two assertions beside each such fixture -- here and in the # "getSelectedSets works" block above -- are the canary for that choice. On a # glmnet that returned a data.frame, the fixtures in THIS block would stop at # the consumer's new guard, but that block's would not: it indexes a single # element out and calls getSelectedSets(), which this PR does not guard, and # a data.frame's [[k]] is column k -- a well-formed integer vector whose # assertions pass silently. The canary makes both blocks fail the same, # legible way instead. # # BOTH assertions are needed, for the same reason the consumer needs two # guards: a data.frame IS a list, so expect_true(is.list(...)) alone passes # on the very container this is watching for. The pair mirrors # getClusterSelsFromGlmnet()'s own stopifnot() pair exactly. lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # Try again with cluster representative lasso X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)), clusters=1:3, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # An all-empty lasso path (max_length == 0) must return an empty selection, # not crash with "model_size > 0 is not TRUE" (#157). out_empty <- getClusterSelsFromGlmnet(list(integer(0)), clusters = list(1L), prototypes = 1L, feat_names = NA) testthat::expect_length(out_empty$selected_sets, 0) testthat::expect_length(out_empty$selected_clusts_list, 0) }) ## Test passed with 594 successes. predict.glmnet(type = \"nonzero\") does not return a stable container across glmnet versions here either, and unlike cssLasso() this path must preserve one slot per penalty rather than flatten them. clusterLassoCore() therefore normalises the result to a list before unique() sees it, and getClusterSelsFromGlmnet() refuses anything else (#190). These blocks mock glmnet::predict.glmnet to hand protolasso() and clusterRepLasso() each container shape directly, so they pin the contract on any machine regardless of which glmnet is installed – a test exercising only the installed version pins nothing about the other one. glmnet() itself is not mocked, so fit is a real fit whose path length is whatever the installed glmnet’s early-stopping heuristics produce (nlambda is a request, not a promise: measured on the protolasso design these blocks build, nlambda = 100 yields 66 penalties, and 61 on the clusterRepLasso() design the multi-column block uses). The mocks that need a whole-path fixture therefore size it from ncol(object$beta) rather than hard-coding a slot count, which would be a stopifnot() error rather than a legible test failure. The two blocks that pin a specific geometry – the square one and the neither-orientation one – hard-code theirs instead, and assert or exploit the path length rather than deriving it. Only the single-column data.frame block is a red-green regression test for the container bug proper. The multi-column, list and square blocks are pins that pass on the pre-fix source too. The blocks named requires one entry per penalty, rejects a data.frame and rejects a non-list pin the boundary’s entry-count assertion and the consumer’s two container guards, each of which is otherwise observed by nothing. The boundary’s own is.list() / !is.data.frame() pair is deliberately unpinned: both are post-conditions on a total normalisation, so nothing short of mocking a container nonzeroCoef() cannot emit would reach them. They stand as defence-in-depth against a future glmnet, and deleting either leaves every block below green – the expected result, not a coverage gap. The inner nrow() check in the row-major branch is a different case and is pinned, by the block named rejects a data.frame of neither orientation. It is that branch’s own disambiguation predicate rather than a post-condition, and its unreachability is empirical – no glmnet in play emits a data.frame whose ncol and nrow both differ from the penalty count – rather than structural, so it is worth one assertion. testthat::test_that("clusterLassoCore normalises a single-column data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # glmnet 4.x's shape when every penalty selected exactly ONE feature: apply() # collapses to a vector, so data.frame() gives a single column with one ROW # per penalty and the column<->penalty convention inverts. Read as a list # this is one model of size n_pen; read correctly it is n_pen models of size # 1. The values must cycle through more than one index, or the two readings # coincide and this block cannot go red. # # The cycle needs n_pen >= 3, so assert it rather than documenting it: at # n_pen == 1 the fixture is a 1 x 1 data.frame, both readings agree, and this # block would pass pre-fix -- a green red-green test, which is worse than no # test at all. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ testthat::expect_gte(ncol(object$beta), 3L) data.frame(which=rep_len(c(1L, 2L, 3L), ncol(object$beta))) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=100) # Pre-fix, unique() dedupes the data.frame's ROWS and lengths() then counts # rows per column, so this fixture is read as max_length = 3: the block sees # selected_sets of length 3, holding a fabricated size-3 model c(1L, 7L, 9L) # that glmnet never selected, and drops the genuine size-1 one. Both # assertions below move. testthat::expect_length(res$selected_sets, 1) testthat::expect_identical(res$selected_sets[[1]], 1L) }) testthat::test_that("clusterLassoCore normalises a multi-column data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # glmnet 4.x's other data.frame layout: every penalty selected the same # NUMBER k >= 2 of features -- the sets may differ, {1,2} and {2,3} qualify # -- so apply() returns a k x n_pen matrix and data.frame() lays out one # COLUMN per penalty. This one degenerates to the right answer # pre-fix -- each column is strictly increasing down the rows, so no two rows # can be equal and unique() is a no-op on it -- which makes this a pin rather # than a red-green test. It holds the column-major branch of the # normalisation against a later refactor, and it goes red if the two branches # are transposed or the reshaping is deleted. # # Driven through clusterRepLasso() so the shared clusterLassoCore() body is # covered from both exported entry points. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ n_pen <- ncol(object$beta) as.data.frame(matrix(rep_len(c(1L, 2L, 1L, 3L), 2L*n_pen), nrow=2L, ncol=n_pen)) }, .package="glmnet") res <- clusterRepLasso(x, y, good_clusters, nlambda=100) # Design indices 1 and 2 are red_cluster and green_cluster, whose prototypes # are features 1 and 7; getSelectedSets() maps the fixture's indices back # through prototypes, so these are not the fixture's own integers. testthat::expect_length(res$selected_sets, 2) testthat::expect_null(res$selected_sets[[1]]) testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L)) }) testthat::test_that("clusterLassoCore leaves the list shape alone (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The branch glmnet 5.0 always takes, and the one 4.x takes here today. # Mixed sizes and a NULL slot, so the fixture is not degenerate. # # This is a pin, not a red-green test, and it is deliberately kept despite # being green pre-fix: measured green under deleting the reshaping and under # replacing it with a bare as.list(), because both leave a list untouched. # What it does catch is applying the reshaping UNCONDITIONALLY -- dropping # the is.data.frame() test on the grounds that "the reshape is harmless on a # list" is the likeliest future edit to that block -- under which it errors # with "'list' object cannot be coerced to type 'integer'". Apart from the # entry-count block below, which trips a different assertion incidentally, # this block catches that. It is not the only one -- an unconditional # reshape reaches as.integer() on a list from every caller, so the # end-to-end protolasso/clusterRepLasso blocks error too -- but it is the # only one of the mocked shape pins that does. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ testthat::expect_gte(ncol(object$beta), 3L) rep_len(list(NULL, 1L, c(1L, 2L)), ncol(object$beta)) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=100) testthat::expect_length(res$selected_sets, 2) testthat::expect_identical(res$selected_sets[[1]], 1L) testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L)) }) testthat::test_that("getClusterSelsFromGlmnet rejects a data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) # The message pin separates the NEW guard from the downstream # all(lasso_set <= length(clusters)) check in getSelectedSets(), which fires # only when the fixture's indices exceed length(clusters). Measured on # 2f66a14 with this five-cluster fixture: the call returns cleanly # (selected_sets of length 2), so a bare expect_error() is red-green here as # well -- but it would go green again on any later edit that made this call # error for some unrelated reason, which is why the pin stays. # # fixed=TRUE is mandatory: the message contains "!", "(" and ".", so it does # not match itself as a regex. testthat::expect_error( getClusterSelsFromGlmnet(data.frame(which=c(1L, 2L)), process$clusters, process$prototypes, process$var_names), "!is.data.frame(lasso_sets) is not TRUE", fixed=TRUE) }) testthat::test_that("clusterLassoCore requires one entry per penalty (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The entry-count assertion is a new bound on the default code path: before # #190 clusterLassoCore() accepted whatever predict.glmnet handed it, # afterwards it refuses anything whose entry count differs from # ncol(fit$beta). Nothing else observes it, so without this block a later # weakening of it would go unnoticed. On glmnet 4.1.9 the bound excludes # nothing (400/400 agreement over random fits); CI's R-CMD-check matrix, # which installs glmnet 5.0, is its cross-version test. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ rep_len(list(1L), ncol(object$beta) + 1L) }, .package="glmnet") testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100), "identical(length(nonzero), n_pen) is not TRUE", fixed=TRUE) }) testthat::test_that("getClusterSelsFromGlmnet rejects a non-list (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) # The data.frame block above can never reach the is.list() guard, because a # data.frame IS a list and its fixture always falls through to the second # guard; this block is the only thing that exercises the first. Measured on # 2f66a14: this call returns cleanly (selected_sets of length 1), so the red # side is a clean "no error was thrown". testthat::expect_error( getClusterSelsFromGlmnet(1:3, process$clusters, process$prototypes, process$var_names), "is.list(lasso_sets) is not TRUE", fixed=TRUE) }) testthat::test_that("clusterLassoCore reads a square data.frame column-major (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The one shape on which BOTH branch predicates are true: k == n_pen, so # ncol(nonzero_mat) == n_pen and nrow(nonzero_mat) == n_pen alike. The # normalisation resolves it by testing ncol first, which is correct -- # apply() simplifies to a matrix only when it has one column per penalty -- # but nothing else in this file pins that ORDER, because no other fixture is # square (the single-column one is n_pen x 1, the multi-column one 2 x n_pen). # # Swapping the predicate and the two readings together is wrong on exactly # this shape and correct everywhere else, so without this block that refactor # passes the whole suite while reintroducing #190's failure mode: confidently # wrong model sizes. Read row-major, slot 1 is ROW 1 -- c(1L, 1L, 1L) -- # which getSelectedSets() rejects for having duplicates. # # nlambda is honoured exactly at small values (measured: 2 -> 2, 3 -> 3), so # a square fixture is directly constructible; assert it rather than trusting # it, since a shortened path would make this block vacuous. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ n_pen <- ncol(object$beta) testthat::expect_identical(n_pen, 3L) as.data.frame(matrix(c(1L, 2L, 3L, 1L, 2L, 4L, 1L, 3L, 4L), nrow=3L, ncol=3L)) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=3) # Prototypes are c(1, 7, 9, 10, 11), so the fixture's first column c(1, 2, 3) # maps to features 1, 7 and 9. testthat::expect_length(res$selected_sets, 3) testthat::expect_null(res$selected_sets[[1]]) testthat::expect_null(res$selected_sets[[2]]) testthat::expect_identical(res$selected_sets[[3]], c(1L, 7L, 9L)) }) ## Test passed with 3 successes. ## Test passed with 3 successes. ## Test passed with 4 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 5 successes. The last of the boundary’s assertions, the row-major branch’s own nrow() check. Unlike the is.list() / !is.data.frame() pair it guards a reachable-in-principle shape – a data.frame whose ncol and nrow both differ from the penalty count – so it costs one assertion rather than being unpinnable. testthat::test_that("clusterLassoCore rejects a data.frame of neither orientation (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Neither ncol nor nrow matches n_pen (66 on this design at nlambda = 100), # so the reshaping cannot tell which orientation it is looking at and stops # instead of guessing. No glmnet in play emits this, which is why the guard # is otherwise unobserved. testthat::local_mocked_bindings( predict.glmnet = function(...) data.frame(a=1:2, b=3:4), .package="glmnet") testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100), "nrow(nonzero_mat) == n_pen is not TRUE", fixed=TRUE) }) ## Test passed with 1 success. Finally, tests for protolasso(): testthat::test_that("protolasso works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(x, y, good_clusters, nlambda=60) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(is.null(names(res$selected_sets[[i]]))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 60) # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] y_df <- rnorm(nrow(X_df)) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(X_df, y_df, 1:3, nlambda=80) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 80) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should get an error if we try to call protolasso on df2 with clusters # because df2 contains factors with more than two levels testthat::expect_error(protolasso(df2, y_df, 4:6, nlambda=70), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- protolasso(df2, y_df, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(X_df_model, y_df, 4:6, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 70) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x2, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(x2, y, good_clusters, nlambda=50) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% LETTERS[1:11])) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 50) # Bad inputs testthat::expect_error(protolasso(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156); the fitted result for a # duplicated cluster is identical to passing the cluster once (seed both). set.seed(921) dup_pl <- protolasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10) set.seed(921) dedup_pl <- protolasso(X=x, y=y, clusters=list(2:3), nlambda=10) testthat::expect_identical(dup_pl, dedup_pl) testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) # (#127) A single all-encompassing cluster (or a genuine p < 2 input) leaves # glmnet with a 1-column design; clusterLassoCore now errors up front with a # cssr message naming both causes, instead of glmnet's "2 or more columns". testthat::expect_error( protolasso(X=x, y=y, clusters=list(all=1:11)), "need at least 2 cluster representatives to fit the lasso", fixed=TRUE) }) ## Test passed with 575 successes. Tests for clusterRepLasso(): testthat::test_that("clusterRepLasso works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(x, y, good_clusters, nlambda=60) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(is.null(names(res$selected_sets[[i]]))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 60) # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] y_df <- rnorm(nrow(X_df)) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(X_df, y_df, 1:3, nlambda=80) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 80) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get an error if we try to call clusterRepLasso on df2 with clusters # because df2 contains factors with more than two levels testthat::expect_error(clusterRepLasso(df2, y_df, 4:6, nlambda=70), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- clusterRepLasso(df2, y_df, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(X_df_model, y_df, 4:6, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 70) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x2, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(x2, y, good_clusters, nlambda=50) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% LETTERS[1:11])) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 50) # Bad inputs testthat::expect_error(clusterRepLasso(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156); identical to passing the # cluster once (seed both). set.seed(921) dup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10) set.seed(921) dedup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3), nlambda=10) testthat::expect_identical(dup_crl, dedup_crl) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) # (#127) Same degenerate-design guard as protolasso: a single all-encompassing # cluster yields a 1-column design, now rejected with a clear cssr message # rather than glmnet's "2 or more columns". testthat::expect_error( clusterRepLasso(X=x, y=y, clusters=list(all=1:11)), "need at least 2 cluster representatives to fit the lasso", fixed=TRUE) }) ## Test passed with 527 successes. Regression test for the empty-lasso-path edge case (#157): testthat::test_that("protolasso/clusterRepLasso return an empty selection when the lasso path selects nothing (#157)", { # X'y must be EXACTLY zero to empty the whole glmnet path (see plan note: # floating-point orthogonality drives lambda_max->0 and selects everything). # Paired +1/-1 integer rows give crossprod(X, y) == 0 exactly. y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1)) X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0), c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1)) storage.mode(X) <- "double" testthat::expect_identical(max(abs(crossprod(X, y))), 0) # exactly orthogonal # Was: crash "model_size > 0 is not TRUE". Now: empty selection, no error. res_p <- protolasso(X, y) testthat::expect_length(res_p$selected_sets, 0) testthat::expect_length(res_p$selected_clusts_list, 0) res_c <- clusterRepLasso(X, y) testthat::expect_length(res_c$selected_sets, 0) testthat::expect_length(res_c$selected_clusts_list, 0) # A normal signal case still selects features (guards against over-fixing). set.seed(2) Xs <- matrix(stats::rnorm(24 * 4), 24, 4) ys <- Xs[, 1] * 2 + stats::rnorm(24, sd = 0.1) testthat::expect_gt(length(protolasso(Xs, ys)$selected_sets), 0) }) ## Test passed with 6 successes. Regression tests for the named output contract of protolasso()/clusterRepLasso(): selected_clusts_list[[k]] is a named list of the selected clusters (#158a). testthat::test_that("protolasso and clusterRepLasso name selected_clusts_list with the selected clusters' names (#158a)", { set.seed(158) n <- 40L p <- 6L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n)) clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L)) # formatClusters reorders to clustA, clustB, then one singleton per unclustered # feature in ascending order (c3 = feature 1, c4 = feature 3). expected_names <- c("clustA", "clustB", "c3", "c4") for (fun in list(protolasso, clusterRepLasso)) { res <- fun(X, y, clusters) testthat::expect_true(any(lengths(res$selected_clusts_list) > 0)) for (k in seq_along(res$selected_clusts_list)) { sk <- res$selected_clusts_list[[k]] if (length(sk) > 0) { testthat::expect_false(is.null(names(sk))) testthat::expect_equal(length(names(sk)), k) testthat::expect_true(all(names(sk) %in% expected_names)) # Name-based indexing returns the same cluster as position-based. testthat::expect_identical(sk[[names(sk)[1]]], sk[[1]]) } } } }) ## Test passed with 26 successes. The rows of beta carry the reordered cluster names, so they cross-reference selected_clusts_list (#158b). testthat::test_that("protolasso and clusterRepLasso beta carries cluster names as rownames (#158b)", { set.seed(158) n <- 40L p <- 6L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n)) clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L)) expected_names <- c("clustA", "clustB", "c3", "c4") for (fun in list(protolasso, clusterRepLasso)) { res <- fun(X, y, clusters) # GUARANTEED equality: one beta row per reordered cluster, in order. testthat::expect_identical(rownames(res$beta), expected_names) # SUBSET cross-check: each selected cluster's name is among beta's rownames # (a never-selected cluster is still a beta row, so this is not equality). for (k in seq_along(res$selected_clusts_list)) { sk <- res$selected_clusts_list[[k]] if (length(sk) > 0) { testthat::expect_true(all(names(sk) %in% rownames(res$beta))) } } } }) ## Test passed with 8 successes. processClusterLassoInputs() rejects an X whose columns are partly named and partly NA-named, with the corrected remedy message (#158d). testthat::test_that("processClusterLassoInputs rejects X with mixed named and NA-named columns (#158d)", { set.seed(158) n <- 20L p <- 4L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- c("g1", NA, "g3", NA) y <- stats::rnorm(n) testthat::expect_error( processClusterLassoInputs(X = X, y = y, clusters = list(), nlambda = 10), "please either name all features in X or remove the names altogether", fixed = TRUE) }) ## Test passed with 1 success. "],["documenting-the-package-and-adding-readme-and-pkgdown-website.html", "13 Documenting the package and adding README and pkgdown website", " 13 Documenting the package and adding README and pkgdown website At build time we generate the package’s reference documentation, README, and pkgdown website: litr::document() writes the man/ pages and NAMESPACE; the README is rendered from source-files/README.Rmd (its two figures copied into man/figures/); the CITATION file is installed so citation(\"cssr\") and the pkgdown “Citation” page cite the paper (arXiv:2201.00494); NEWS.md is copied to the package root from source-files/NEWS.md, where it is edited, so that news(package = \"cssr\") and the pkgdown “Changelog” page both have it (it must be copied before litr::add_pkgdown() runs below, since that is what builds the changelog page); and the WORDLIST file is installed alongside CITATION so that devtools::spell_check() accepts this package’s domain vocabulary and flags only genuine misspellings. Its entries fall into a few groups: author surnames and the journals that published them; package, function, and argument names; data-frame column names; fragments of underscore-separated identifiers, which appear because the spell checker splits tokens at underscores (so X_train_selec contributes selec, and clus_sel_mat contributes clus and sel — these are documented argument and slot names, not truncations); a few mathematical and typographic tokens from the README’s LaTeX; the R color literals grey and steelblue, which are spellings fixed by R’s own palette rather than by us and so are quoted verbatim from default argument values; and a handful of ordinary English words the en_US dictionary happens to lack. Everything else is treated as a typo and fixed at the source; the Exploring results, Prediction, and Advanced usage vignettes are added from source-files/ via litr::add_vignettes(); and litr::add_pkgdown() builds the site (including the vignettes under Articles). "],["404.html", "Page not found", " Page not found The page you requested cannot be found (perhaps it was moved or renamed). You may want to try searching to find the page's new location, or use the table of contents to find the page you are looking for. "]]
+[["index.html", "Creating the cssr R package 1 Introduction", " Creating the cssr R package Gregory Faletto September 10, 2026 1 Introduction Cluster stability selection is a feature selection method designed to allow stability selection to work effectively in the presence of highly correlated features. It was proposed in this paper: ###"faletto2022"### #' Faletto, G., & Bien, J. (2022). Cluster Stability Selection. #' \\emph{arXiv preprint arXiv:2201.00494}. #' \\url{https://arxiv.org/abs/2201.00494}. This bookdown uses literate programming to define the cssr R package, which implements the procedures described in the paper. For a light introduction demonstrating how to use cssr, please see the package’s website here. "],["overview.html", "2 Overview 2.1 Background 2.2 Outline 2.3 Package setup", " 2 Overview 2.1 Background 2.1.1 Complementary pairs stability selection The following paper introduces complementary pairs subsampling: ###"shah2013"### #' Shah, R. D., & Samworth, R. J. #' (2013). Variable selection with error control: Another look at stability #' selection. \\emph{Journal of the Royal Statistical Society. Series B: #' Statistical Methodology}, 75(1), 55–80. #' \\url{https://doi.org/10.1111/j.1467-9868.2011.01034.x}. Subsamples \\(A_1, \\ldots, A_B \\subset [n]\\) of size \\(\\lfloor n/2 \\rfloor\\) are drawn, as well as subsamples \\(\\overline{A}_b \\subset [n]\\) of the same size with \\(A_b \\cap \\overline{A}_b = \\emptyset\\). Our function getSubsamps() implements this subsampling. Writing \\(\\hat{S}^\\lambda(A)\\) for the selected features from applying a variable selection procedure with tuning parameter \\(\\lambda\\) on the data in a subset \\(A\\subset[n]\\), Shah and Samworth suggest computing the following: \\[ \\hat{\\Pi}_B^{\\text{(SS)}}(j) = \\frac{1}{2B} \\sum_{b=1}^B \\left[1\\left\\{j \\in \\hat{S}^\\lambda \\left( A_b \\right)\\right\\} + 1\\left\\{j \\in \\hat{S}^\\lambda (\\overline{A}_b)\\right\\} \\right]. \\] 2.1.2 Cluster stability selection We compute the proportion of the time that a feature \\(j \\in [p]\\) is selected for at least one \\(\\lambda \\in \\Lambda\\): \\[ \\hat{\\Pi}_B(j) := \\frac{1}{2B} \\sum_{b=1}^B \\left[ 1\\left\\{ j \\in \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^\\lambda \\left( A_b \\right) \\right\\} + 1\\left\\{ j \\in \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^\\lambda (\\overline{A}_b)\\right\\} \\right]. \\] We also compute a similar quantity at the level of clusters: For every cluster \\(C_k\\), we calculate the proportion of the time that at least one feature from \\(C_k\\) is selected for at least one \\(\\lambda \\in \\Lambda\\): \\[ \\hat{\\Theta}_B(C_k) := \\frac{1}{2B} \\sum_{b=1}^B \\left[ 1 \\left\\{ C_k \\cap \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^{\\lambda}\\left(A_b \\right) \\neq \\emptyset \\right\\} + 1 \\left\\{ C_k \\cap \\bigcup_{\\lambda \\in \\Lambda} \\hat{S}^{\\lambda}\\left(\\overline{A}_b \\right) \\neq \\emptyset \\right\\} \\right]. \\] We then calculate cluster representatives \\(\\boldsymbol{X}_{\\cdot C_k}^{\\text{rep}}\\) as weighted averages of the cluster members: \\[ \\boldsymbol{X}_{\\cdot C_k}^{\\text{rep}}:= \\sum_{j \\in C_k } w_{kj} \\boldsymbol{X}_{\\cdot j}. \\] We allow for several choices of weights: Weighted averaged cluster stability selection: \\[ w_{kj} = \\frac{\\hat{\\Pi}_B(j)}{\\sum_{j' \\in C_k} \\hat{\\Pi}_B(j')} \\qquad \\forall j \\in C_k . \\] Simple averaged cluster stability selection: \\[ w_{kj} = \\frac{1}{\\left| C_k \\right|} \\qquad \\forall j \\in C_k . \\] Sparse cluster stability selection: For each \\(j \\in C_k\\), \\[ w_{kj} = \\left. 1 \\left\\{ j \\in \\underset{j' \\in C_k}{\\arg \\max} \\left\\{ \\hat{\\Pi}_B(j') \\right\\} \\right\\} \\middle/ \\left| \\underset{j' \\in C_k}{\\arg \\max} \\left\\{ \\hat{\\Pi}_B(j') \\right\\} \\right| \\right. . \\] 2.2 Outline We will define the functions in this package in steps. First we define the workhorse function of the package, css(). This function takes as inputs a data set (\\(X\\), \\(y\\)), a feature selection method \\(\\hat S^\\lambda(\\cdot)\\), and clusters of features appearing in the data: \\(C_1,\\ldots,C_K\\). It calculates random subsamples of the data (\\(A_1,\\ldots, A_B\\) and \\(\\bar A_1,\\ldots, \\bar A_B\\)) and gets selected sets of features on each subsample (i.e., \\(\\hat S^\\lambda(A_b)\\) and \\(\\hat S^\\lambda(\\bar A_b)\\)). It returns a \\(2B\\times p\\) matrix of indicator variables for whether each feature was selected on each subsample (one row for each subsample, one column for each feature). It returns a similar \\(2B\\times K\\) matrix of indicator variables for whether any feature from each cluster was selected on each subsample. This is the most computationally intensive step of cluster stability selection, so it is isolated within its own function that is designed to be run only once on a data set. Next we define functions that take these indicator matrices and return useful output–for example, selected sets of features, or predictions on test data. These outputs depend on the selected features, which themselves depend on user-selected parameters (for example, the cutoff for selection proportions for selected clusters). Next, we define wrapper functions that compute all of the above in one step in a user-friendly way. (These functions are not recommended for large data sets or for “power users” who may want to call these functions multiple times on the same data set, because these wrapper functions make a new call to css() every time they are called, which is slow and computationally wasteful if the inputs to css() are not changed.) Finally, we define some other useful functions, like functions that generate clustered data to use for simulations or testing, or select a tuning parameter for the lasso via cross-validation. 2.3 Package setup Before proceeding to the actual functionality of the package, we start by specifying the information needed in the DESCRIPTION file of the R package. usethis::create_package( path = ".", fields = list( Package = params$package_name, Version = "0.4.7.9000", Title = "Cluster Stability Selection", Description = "Implementation of Cluster Stability Selection, a feature selection method proposed in Faletto and Bien (2022) <arXiv:2201.00494>.", Language = "en-US", URL = "https://gregfaletto.github.io/cssr-project/, https://github.com/gregfaletto/cssr-project", BugReports = "https://github.com/gregfaletto/cssr-project/issues", `Authors@R` = c(person( given = "Gregory", family = "Faletto", email = "gregory.faletto@marshall.usc.edu", role = c("aut", "cre", "cph") ), person( given = "Jacob", family = "Bien", email = "jbien@usc.edu", role = c("aut", "cph") )) ) ) usethis::use_mit_license(copyright_holder = "Gregory Faletto and Jacob Bien") We also define the package-level documentation that shows up when someone types package?cssr in the console: #' Cluster Stability Selection #' #' Cluster stability selection is a feature selection method designed to allow #' stability selection to work effectively in the presence of highly correlated #' features. It was proposed in <https://arxiv.org/abs/2201.00494>. To learn #' more about this package, please visit its website #' <https://gregfaletto.github.io/cssr-project/>. #' #' @docType package #' @seealso \\code{\\link{css}} \\code{\\link{cssSelect}} "],["css.html", "3 The core function: css 3.1 Main components of css 3.2 Helper functions", " 3 The core function: css The main inputs that css() accepts are the following: a design matrix X a response y a selection method fitfun with specified tuning parameter lambda. This specifies \\(\\hat{S}^\\lambda(A)\\). In particular: ###"param-fitfun"### #' @param fitfun A function; the feature selection function used on each #' subsample by cluster stability selection. This can be any feature selection #' method; the only requirement is that it accepts the arguments (and only the #' arguments) `X`, `y`, and `lambda` and returns an integer vector that is a #' subset of `1:p`. For example, `fitfun` could be best subset selection or #' forward stepwise selection or LARS and `lambda` could be the desired model #' size; or `fitfun` could be the elastic net and `lambda` could be a length-two #' vector specifying lambda and alpha. Default is `cssLasso`, an implementation #' of lasso (relying on the R package `glmnet`), where `lambda` must be a #' nonnegative numeric specifying the L1 penalty for the `lasso`, or a named #' length-2 vector `c(lambda, alpha)` for an elastic net fit (see `cssLasso`). and ###"param-lambda"### #' @param lambda A tuning parameter or set of tuning parameters that may be used #' by the feature selection method `fitfun`. In the default case when #' `fitfun = cssLasso`, lambda is a nonnegative numeric (or a named `c(lambda, alpha)` for an elastic net fit; see `cssLasso`): the penalty to use for each #' lasso fit. (`css()` does not require lambda to be any particular object because #' for a user-specified feature selection method `fitfun`, lambda can be an #' arbitrary object. See the description of `fitfun` below.) a specification of which features belong together in highly correlated clusters. This specifies the clusters \\(C_1,\\ldots, C_K\\). In particular: ###"param-clusters"### #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of `1:p`). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. If the same cluster is #' provided more than once, the duplicates will be removed, keeping only the #' first occurrence (and its name). Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). If #' clusters is a list of length 0 (or a list only containing clusters of length #' 1), then `css()` returns the same results as stability selection (so the #' returned `feat_sel_mat` will be identical to `clus_sel_mat`). Names for the #' clusters will be needed later; any clusters that are not given names in the #' provided list will be given names automatically by `css()`. CAUTION: if #' the provided X is a data.frame that contains a categorical feature with more #' than two levels, then the resulting matrix made from model.matrix will have a #' different number of columns than the provided data.frame, some of the feature #' numbers will change, and the clusters argument will not work properly (in the #' current version of the package). To get correct results in this case, please #' use model.matrix to convert the data.frame to a numeric matrix on your own, #' then provide this matrix and cluster assignments with respect to this matrix. #' Default is `list()` (so no clusters are specified). and a specification of the type of subsamples. For now we only consider the complementary subsets sampling of Shah and Samworth. However, we have included an option for Meinshausen-Buhlmann sampling which we may add later: ###"param-sampling_type"### #' @param sampling_type A character vector; either "SS" or "MB". For "MB", #' all B subsamples are drawn randomly (as proposed by Meinshausen and Bühlmann #' 2010). For "SS", in addition to these B subsamples, the B complementary pair #' subsamples will be drawn as well (see Faletto and Bien 2022 or Shah and #' Samworth 2013 for details). Default is "SS", and "MB" is not supported yet. The number of subsamples is also up to the user: ###"param-B"### #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. In this section, we will build the function css() step-by-step. First, css() creates random subsamples of the data: \\(A_1,\\ldots, A_B\\) (and \\(\\bar A_1,\\ldots, \\bar A_B\\) for Shah-Samworth subsampling). This is implemented in the function createSubsamples(). Next, css() executes the specified feature selection method \\(\\hat S^\\lambda(\\cdot)\\) on each subsample. This generates a binary matrix, feat_sel_mat, with one row for each subsample and one column for each feature in X. In each row, the entry corresponding to each feature equals 1 if the feature was selected on that subsample and 0 otherwise. feat_sel_mat is one of the outputs of css(); it is used to calculate the selection proportions for individual features. This is implemented in the function getSelMatrix(). So far this is the same as the original stability selection procedure. Now we take into account the clusters. The function getClusterSelMatrix() takes in the formatted clusters as well as feat_sel_mat and generates the binary matrix clus_sel_mat, which contains selection indicators for each cluster. clus_sel_mat has the same number of rows as feat_sel_mat and one column for each cluster rather than one for each feature. This is used to calculate the cluster selection proportions. The function css() is specified below. (There are some extra details that I omitted in the above description for brevity; you can read the full details below.) #' Cluster Stability Selection #' #' Executes cluster stability selection algorithm. Takes subsamples of data, #' executes feature selection algorithm on each subsample, and returns matrices #' of feature selection indicators as well as cluster selection indicators. #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; can be anything that takes the form of an #' n-dimensional vector, with the ith entry corresponding to the ith row of X. #' Typically (and for default `fitfun = cssLasso`), `y` should be an n-dimensional #' numeric vector. Note that for the default `fitfun = cssLasso`, `y` must not be #' too discrete: every random subsample of `y` (of size `floor(n/2)`) must contain #' more than one unique value, or css aborts. Because the subsamples are random, #' such an abort is seed-dependent and becomes more likely as `B` grows; if it #' occurs, supply a less discrete (more continuous) response or a custom `fitfun` #' that tolerates a constant-`y` subsample. <<param-lambda>> <<param-clusters>> <<param-fitfun>> <<param-sampling_type>> <<param-B>> #' @param prop_feats_remove Numeric; if `prop_feats_remove` is greater than 0, #' then on each subsample, each feature is randomly dropped from the design #' matrix that is provided to `fitfun` with probability `prop_feats_remove` #' (independently across features). That is, in a typical subsample, #' `prop_feats_remove*p` features will be dropped (though this number will vary). #' This is similar in spirit (but distinct from) extended stability selection #' (Beinrucker et. al. 2016); see their paper for some of the benefits of #' dropping features (besides increasing computational speed and decreasing #' memory requirements). For `sampling_type="SS"`, the features dropped in #' each complementary pair of subsamples are identical in order to ensure that #' the theoretical guarantees of Faletto and Bien (2022) are retained within #' each individual pair of subsamples. (Note that this feature is not #' investigated either theoretically or in simulations by Faletto and Bien #' 2022). Must be between 0 and 1. Default is 0. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in `X` and `y` to set aside for model training by the #' function `getCssPreds()` after feature selection. (This will only work if `y` is #' real-valued, because `getCssPreds()` using ordinary least squares regression to #' generate predictions.) If `train_inds` is not provided, all of the observations #' in the provided data set will be used for feature selection. #' @param num_cores Optional; an integer. The number of cores to use for #' parallel processing (supplied internally as the `mc.cores` argument of #' `parallel::mclapply()`). The per-subsample feature-selection loop is the #' dominant cost and is embarrassingly parallel, so on a multi-core Unix or #' macOS machine setting `num_cores > 1` gives a substantial speedup; the result #' is identical regardless of `num_cores` (per-subsample seeds are fixed). #' On Windows, forking is unavailable, so `num_cores > 1` is not supported; #' `css()` warns and runs serially (`num_cores = 1`) there. Default is #' 1 (serial). #' @return A list containing the following items: #' \\item{`feat_sel_mat`}{A `B` (or `2*B` for `sampling_type="SS"`) x `p` numeric (binary) matrix. `feat_sel_mat[i, j] = 1` if feature `j` was selected by the base feature selection method on subsample `i`, and 0 otherwise.} #' \\item{`clus_sel_mat`}{A `B` (or `2*B` for SS sampling) x `length(clusters)` numeric (binary) matrix. `clus_sel_mat[i, j] = 1` if at least one feature from cluster j was selected by the base feature selection method on subsample `i`, and 0 otherwise.} #' \\item{`X`}{The `X` matrix provided to `css()`, coerced from a data.frame to a #' matrix if needed.} #' \\item{`y`}{The `y` vector provided to `css()`.} #' \\item{`clusters`}{A named list of integer vectors containing all of the clusters provided to `css()`, as well as size 1 clusters of any features not listed in any #' of the clusters provided to `css()`. All clusters will have names; any #' clusters not provided with a name in the input to `css()` will be given names #' automatically by `css()` (of the form c1, etc.).} #' \\item{`train_inds`}{Identical to the `train_inds` provided to `css()`.} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' <<shah2013>> #' #' Meinshausen, N., & Bühlmann, P. (2010). Stability Selection. \\emph{Journal of the Royal #' Statistical Society. Series B: Statistical Methodology}, 72(4), 417–473. #' \\url{https://doi.org/10.1111/j.1467-9868.2010.00740.x}. #' #' Beinrucker, A., Dogan, Ü., & #' Blanchard, G. (2016). Extensions of stability selection using subsamples of #' observations and covariates. \\emph{Statistics and Computing}, 26(5), 1059- #' 1077. \\url{https://doi.org/10.1007/s11222-015-9589-y}. #' #' Jerome Friedman, Trevor Hastie, Robert Tibshirani (2010). Regularization Paths for Generalized #' Linear Models via Coordinate Descent. \\emph{Journal of Statistical Software}, #' 33(1), 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' print(res) #' # On a multi-core Unix/macOS machine, set num_cores for a substantial #' # speedup (identical results; num_cores > 1 falls back to serial on Windows): #' \\donttest{ #' res_par <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10, num_cores = min(2L, parallel::detectCores())) #' } #' @export css <- function(X, y, lambda, clusters = list(), fitfun = cssLasso, sampling_type = "SS", B = 50L, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L ){ # Check inputs check_list <- checkCssInputs(X, y, lambda, clusters, fitfun, sampling_type, B, prop_feats_remove, train_inds, num_cores) feat_names <- check_list$feat_names X <- check_list$X clusters <- check_list$clusters rm(check_list) # num_cores > 1 needs forking (parallel::mclapply), which is unavailable on # Windows -- there mclapply hard-errors for mc.cores > 1 rather than running # serially. Downgrade to serial with a warning so css() still runs (#155d). if(num_cores > 1L && runningOnWindows()){ warning("num_cores > 1 is not supported on Windows (parallel::mclapply requires forking); running serially with num_cores = 1.") num_cores <- 1L } n <- nrow(X) p <- ncol(X) train_inds <- as.integer(train_inds) ### Create subsamples sel_inds <- setdiff(1:n, train_inds) n_sel <- length(sel_inds) if(n_sel < 4){ if(length(train_inds) == 0){ stop(paste0("Sample size n = ", n, " is too small; css needs at least 4 observations for feature selection.")) } else { stop("Too many training indices provided (must be at least 4 observations left for feature selection, and ideally many more)") } } subsamps_object <- createSubsamples(n_sel, p, B, sampling_type, prop_feats_remove) ### Get matrix of selected feature sets from subsamples stopifnot(!is.matrix(y)) # When train_inds is empty (the default), sel_inds is 1:n, so X[sel_inds, ] # / y[sel_inds] would just materialize a full-size copy of X / y for nothing # (getSelMatrix re-indexes rows per subsample anyway). Pass X / y directly in # that case; the result is byte-identical, since X[1:n, ] equals X (same # values and dimnames) and y[1:n] equals y. (#129) sel_X <- if(length(train_inds) == 0) X else X[sel_inds, ] sel_y <- if(length(train_inds) == 0) y else y[sel_inds] # Up-front diagnostic (#131): for the default cssLasso a highly discrete y can # leave some random size-floor(n/2) subsample with only one unique value, which # aborts the run non-deterministically (checkCssLassoInputs). Warn when that # estimated probability is non-negligible. Gated to the default cssLasso (custom # fitfuns may tolerate a constant-y subsample) and to finite numeric/integer y: # a non-numeric or non-finite y fails cssLasso for a different, more basic # reason (checkCssLassoInputs), and a non-finite value (Inf/NA) would otherwise # be miscounted by table() as a dominating value, so a discreteness warning # there would be misleading. Consumes no RNG (table/lchoose only), so the # selection below is byte-identical. if(identical(fitfun, cssLasso) && (is.numeric(sel_y) || is.integer(sel_y)) && all(is.finite(sel_y))){ abort_prob <- discreteYAbortProb(sel_y, B, sampling_type) # Warn only above a 5% estimated abort probability: high enough to stay # silent on common discrete data (balanced/moderate y compute to ~0) while # still catching genuinely majority-dominated y. Tunable constant. (#131) if(abort_prob > 0.05){ warning(paste0("The response y appears highly discrete: there is an ", "estimated ", round(100 * abort_prob), "% chance that at least one ", "random subsample of y (of size floor(n/2)) will contain only one ", "unique value, which aborts the default cssLasso (see its error). ", "Consider a less discrete (more continuous) response, a smaller B, ", "or a custom fitfun that tolerates a constant-y subsample.")) } } feat_sel_mat <- getSelMatrix(sel_X, sel_y, lambda, B, sampling_type, subsamps_object, num_cores, fitfun) if(any(!is.na(feat_names))){ colnames(feat_sel_mat) <- feat_names colnames(X) <- feat_names } ### Get selection proportions for clusters corresponding to each feature clus_sel_mat <- getClusterSelMatrix(clusters, feat_sel_mat) # Check outputs stopifnot(!is.null(colnames(clus_sel_mat))) stopifnot(all(colnames(clus_sel_mat) == names(clusters))) ret <- list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat, X = X, y = y, clusters = clusters, train_inds = train_inds ) class(ret) <- "cssr" return(ret) } Tests for css() and the other functions in this section are collected in the Tests chapters at the end of this document (the Tests part). Next, we’ll build the individual functions one at a time. (The one function above that I didn’t mention at all is checkCssInputs(), which confirms that the inputs to css() are as expected and does some basic formatting on the inputs. To streamline presentation, this and other helper functions are specified later.) 3.1 Main components of css 3.1.1 Generating subsamples The function createSubsamples() is responsible for generating the subsamples \\(A_b\\), where \\(b\\) ranges from 1 to \\(B\\) or 1 to \\(2B\\) depending on the type of subsampling: #' Creates lists of subsamples for stability selection. #' #' @param n Integer or numeric; sample size of the data set. #' @param p Integer or numeric; number of features. <<param-B>> <<param-sampling_type>> #' @param prop_feats_remove Numeric; the proportion of features (between 0 and 1) #' that are dropped (and not provided to the feature selection method) on each #' subsample. Default is 0. #' @return A list of length `B` (or `2*B` for `sampling_type = "SS"`). If #' `prop_feats_remove = 0`, each list element is an integer vector of length #' `floor(n/2)` containing the indices of a subsample of `1:n`. (For #' `sampling_type=="SS"`, the last `B` subsamples will be complementary pairs of #' the first `B` subsamples; see Faletto and Bien 2022 or Shah and Samworth 2013 #' for details.) If `prop_feats_remove > 0`, each element is a named list with #' members "subsample" (same as above) and "feats_to_keep", a logical vector #' of length `p`; `feats_to_keep[j] = TRUE` if feature `j` is chosen for this #' subsample, and false otherwise. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' <<shah2013>> #' @keywords internal #' @noRd createSubsamples <- function(n, p, B, sampling_type, prop_feats_remove=0){ # Check inputs stopifnot(length(n) == 1) stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n > 0) stopifnot(length(p) == 1) stopifnot(is.numeric(p) | is.integer(p)) stopifnot(p == round(p)) stopifnot(p > 0) checkSamplingType(sampling_type) checkPropFeatsRemove(prop_feats_remove, p) if(prop_feats_remove == 0){ subsamples <- getSubsamps(n, B, sampling_type) return(subsamples) } else{ # In this case, we generate subsamples as well as logical vectors # of features to keep # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). subsamps_and_feats <- vector("list", if(sampling_type == "SS") 2L*B else B) subsamples <- getSubsamps(n, B, sampling_type) for(i in 1:B){ # Logical p-vector, where each entry is TRUE with probability # 1 - prop_feats_remove feats_to_keep_i <- as.logical(stats::rbinom(n=p, size=1, prob=1 - prop_feats_remove)) # Make sure at least two entries are equal to TRUE (so that at # least two features are present for every subsample)--if not, # randomly choose features to add while(sum(feats_to_keep_i) < 2){ false_inds <- which(!feats_to_keep_i) sel_feat <- sample(false_inds, size=1) feats_to_keep_i[sel_feat] <- TRUE } subsamps_and_feats[[i]] <- list(subsample=subsamples[[i]], feats_to_keep=feats_to_keep_i) } # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). if(sampling_type=="SS"){ stopifnot(length(subsamples) == 2*B) for(i in 1:B){ # Keep the same features as in the other subsample (this # ensures that the theoretical guarantee of Shah and Samworth # 2013 remains valid on every individual pair of subsamples) subsamps_and_feats[[B + i]] <- list(subsample=subsamples[[B + i]], feats_to_keep=subsamps_and_feats[[i]]$feats_to_keep) } } # Check output: every element is a named list(subsample, feats_to_keep). # (The previous check ran on the unnamed OUTER list -> all(logical(0)) # -> vacuously TRUE; this validates the per-element invariant. #69) stopifnot(all(vapply(subsamps_and_feats, function(s) identical(names(s), c("subsample", "feats_to_keep")), logical(1)))) return(subsamps_and_feats) } # Shouldn't be possible to reach this part of function stop("createSubsamples failed to return anything") } Notice that createSubsamples() calls some helper functions to check the inputs (again, these are specified later in the helper functions section). createSubsamples() also calls the workhorse function getSubsamps() to generate a list of subsamples. #' Generate list of subsamples #' #` Generate list of `B` (or `2*B` for sampling_type="SS") subsamples of size #` `n/2` #' @param n Integer or numeric; sample size of the data set. <<param-B>> <<param-sampling_type>> #' @return A list of length `B` (or `2*B` for `sampling_type="SS"`), where each #' element is an integer vector of length `floor(n/2)` containing the indices #' of a subsample of `1:n`. For `sampling_type=="SS"`, the last `B` subsamples #' will be complementary pairs of the first `B` subsamples (see Faletto and #' Bien 2022 or Shah and Samworth 2013 for details). #' @author Gregory Faletto, Jacob Bien #' @references #' <<faletto2022>> #' <<shah2013>> #' @keywords internal #' @noRd getSubsamps <- function(n, B, sampling_type){ subsamples <- vector("list", B) for(i in 1:B){ subsamples[[i]] <- sort(sample.int(n=n, size=floor(n/2), replace=FALSE)) } stopifnot(length(subsamples) == B) # Only the "SS" branch is implemented; "MB" is withheld by checkSamplingType (see #138). if(sampling_type=="SS"){ for(i in 1:B){ # For the ith entry, take a subsample of size floor(n/2) from the # remaining n - floor(n/2) observations. (Only necessary to actually # take the subsample if n is odd; if not, the set we want is # setdiff(1:n, subsamples[[i]]), so skip the sample function.) if(n/2 == floor(n/2)){ subsamples[[B + i]] <- sort(setdiff(1:n, subsamples[[i]])) } else{ subsamples[[B + i]] <- sort(sample(x=setdiff(1:n, subsamples[[i]]), size=floor(n/2), replace=FALSE)) } # Check output stopifnot(is.integer(subsamples[[B + i]])) stopifnot(all(subsamples[[B + i]] == round(subsamples[[B + i]]))) stopifnot(floor(n/2) == length(subsamples[[B + i]])) stopifnot(length(subsamples[[B + i]]) == length(unique(subsamples[[B + i]]))) } stopifnot(length(subsamples) == 2*B) } return(subsamples) } 3.1.2 Forming selection matrices The next function called in the body of css() is getSelMatrix(), which records for each feature \\(j\\) and subsample \\(b\\) whether \\(j\\in \\hat S^\\lambda(A_b)\\): #' Generates matrix of selection indicators from stability selection. #' #' @param x an n x p numeric matrix or a data.frame containing the predictors. #' @param y A response vector; can be any response that takes the form of a #' length n vector and is used (or not used) by fitfun. Typically (and for #' default fitfun = cssLasso), y should be an n-dimensional numeric vector #' containing the response. <<param-lambda>> <<param-B>> <<param-sampling_type>> #' @param subsamps_object A list of length `B` (or `2*B` if `sampling_type="SS"`), #' where each element is one of the following: #' - `subsample`: An integer vector of size `n/2` containing the indices of the #' observations in the subsample. #' - `drop_var_input`: A named list containing two elements: one named #' "subsample", matching the previous description, and a logical vector named #' "feats_to_keep" containing the indices of the features to be automatically #' selected. #' #' (The first object is the output of the function `createSubsamples()` when the #' provided `prop_feats_remove` is 0, the default, and the second object is the #' output of `createSubsamples()` when `prop_feats_remove > 0`.) #' @param num_cores Optional; an integer. If using parallel processing, the #' number of cores to use for parallel processing (num_cores will be supplied #' internally as the mc.cores argument of parallel::mclapply). <<param-fitfun>> #' @return A binary integer matrix of dimension `B` x `p` (if sampling_type == #' "MB") or `2*B` x `p` (if sampling_type == "SS"). `res[i, j]` = 1 if feature j #' was selected on subsample i and equals 0 otherwise. (That is, each row is a #' selected set.) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelMatrix <- function(x, y, lambda, B, sampling_type, subsamps_object, num_cores, fitfun=cssLasso){ # Check inputs stopifnot(is.matrix(x)) stopifnot(all(!is.na(x))) n <- nrow(x) p <- ncol(x) stopifnot(length(y) == n) stopifnot(!is.matrix(y)) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. checkSamplingType(sampling_type) # Get list of selected feature sets from subsamples # Reproducible per-subsample seeding (issue #12): draw one seed per # subsample from the caller's RNG, then seed inside cssLoop right before # fitfun runs, so a stochastic fitfun is reproducible and identical across # serial/parallel/platform/num_cores given a seed set before css(). The # default cssLasso is deterministic and ignores the seed. Save and restore # .Random.seed so css() leaves the caller's RNG where the (pre-existing) # subsampling left it. if(exists(".Random.seed", envir=.GlobalEnv)){ old_seed <- get(".Random.seed", envir=.GlobalEnv) on.exit(assign(".Random.seed", old_seed, envir=.GlobalEnv), add=TRUE) } seeds <- sample.int(.Machine$integer.max, length(subsamps_object)) res_list <- parallel::mclapply(X=seq_along(subsamps_object), FUN=function(i){ warns <- list() value <- withCallingHandlers( tryCatch( cssLoop(subsamps_object[[i]], x=x, y=y, lambda=lambda, fitfun=fitfun, seed=seeds[i]), # (#155a) tag the TRUE subsample index at the point of failure # so prescheduling can't misattribute it in the assembly loop. error=function(e) structure(list(i=i, msg=conditionMessage(e)), class="cssr_loop_error") ), # (#155b) collect fitfun warning CONDITIONS from the (possibly # forked) worker; re-emitted in the parent below so they surface # the same regardless of num_cores. Collect the condition object # (not just conditionMessage) so a custom warning's subclass/call # survives (conditions serialize across the fork). warning=function(w){ warns[[length(warns) + 1L]] <<- w; invokeRestart("muffleWarning") } ) list(value=value, warnings=warns) }, mc.cores=num_cores) # mclapply returns NULL for any subsample whose worker was killed (e.g. the # OS out-of-memory killer). That NULL is distinct from a legitimate # integer(0) "selected nothing" result, so catch it here rather than letting # the assembly loop's length(res_list[[i]]) == 0 branch silently record it as # a zero row (which would bias the selection proportions). if(any(vapply(res_list, is.null, logical(1)))){ stop("A parallel worker failed (returned NULL) on at least one subsample; re-run with num_cores = 1 to see the underlying error.") } # (#155b) Re-emit fitfun warning conditions in subsample order, then unwrap # so the assembly loop below sees the plain results. for(i in seq_along(res_list)){ for(w in res_list[[i]]$warnings){ warning(w) } res_list[[i]] <- res_list[[i]]$value } # Store selected sets in B x p (or `2*B` x p for "SS") binary matrix if(sampling_type=="SS"){ res <- matrix(0L, 2*B, p) } else if(sampling_type=="MB"){ # Not yet reachable: MB is withheld by checkSamplingType (kept for future support). res <- matrix(0L, B, p) } else{ stop("!(sampling_type %in% c(SS, MB)) (don't know how to set dimensions of res") } stopifnot(length(res_list) == nrow(res)) # Get selected sets into matrix res for(i in 1:nrow(res)){ if(length(res_list[[i]]) == 0){ # If no features are selected, don't fill in anything in this row next } if(!is.integer(res_list[[i]])){ stop(fitfunFailureMessage(res_list[[i]], i)) } stopifnot(length(res_list[[i]]) <= p & length(res_list[[i]]) > 0) stopifnot(all(!is.na(res_list[[i]]))) stopifnot(max(res_list[[i]]) <= p) stopifnot(min(res_list[[i]]) >= 1) stopifnot(length(res_list[[i]]) == length(unique(res_list[[i]]))) stopifnot(!("try-error" %in% class(res_list[[i]]) | "error" %in% class(res_list[[i]]) | "simpleError" %in% class(res_list[[i]]) | "condition" %in% class(res_list[[i]]))) # Store selected variables in the ith row of res res[i, res_list[[i]]] <- 1L } # Check output stopifnot(is.matrix(res)) if(sampling_type=="SS"){ stopifnot(nrow(res) == 2*B) } else{ stopifnot(nrow(res) == B) } stopifnot(ncol(res) == p) stopifnot(all(res %in% c(0, 1))) return(res) } Again, getSelMatrix() uses some helper functions to check the inputs for safety. getSelMatrix() leverages the function parallel::mclapply() package, in order to allow for parallel processing if the user has set this up. This requires a helper function cssLoop(), which is also specified in the later section for helper functions. We add the parallel package to the DESCRIPTION file: usethis::use_package("parallel") ## v Adding parallel to 'Imports' field in DESCRIPTION. ## [ ] Refer to functions with `parallel::fun()`. getSelMatrix() also uses a feature selection function fitfun as an input. fitfun can be provided by the user as an input to css(). We provide one default fitfun, cssLasso(), which works on a real-valued response y given a specified nonnegative penalty parameter lambda >= 0. Both for its own importance and to show an example of a valid fitfun, we show cssLasso() here. #' Provided fitfun implementing the lasso #' #' Function used to select features with the lasso on each subsample in cluster #' stability selection. Uses glmnet implementation of the lasso. #' @param X A design matrix containing the predictors. (In practice this will #' be a subsample of the full design matrix provided to `css()`.) #' @param y A numeric vector containing the response. #' @param lambda Either a single nonnegative number for the lasso penalty to #' use on each subsample (in which case a pure lasso fit, alpha = 1, is used), #' or a named length-2 numeric vector `c(lambda = <value>, alpha = <value>)` #' bundling the penalty together with the elastic net mixing parameter alpha #' (which must be in `(0, 1]`); in the latter case an elastic net fit with that #' alpha is used. (For now, only one lambda value can be provided to #' `cssLasso()`; in the future, we plan to allow for multiple lambda values to be #' provided to `cssLasso()`, as described in Faletto and Bien 2022.) #' @return An integer vector; the indices of the features selected by the lasso. #' @author Gregory Faletto, Jacob Bien #' @references #' <<faletto2022>> #' #' Jerome Friedman, Trevor Hastie, #' Robert Tibshirani (2010). Regularization Paths for Generalized Linear Models #' via Coordinate Descent. \\emph{Journal of Statistical Software}, 33(1), 1-22. #' URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' # cssLasso is the default base feature-selection method used by css(); #' # it returns the integer indices selected at the given lambda. #' selected <- cssLasso(X = data$X, y = data$y, lambda = 0.01) #' selected #' @export cssLasso <- function(X, y, lambda){ # Check inputs checkCssLassoInputs(X, y, lambda) n <- nrow(X) p <- ncol(X) # lambda may be either a single nonnegative number (pure lasso, as in the # original implementation) or a named length-2 numeric vector # c(lambda=<value>, alpha=<value>) bundling the elastic net mixing # parameter alpha alongside the penalty. Unpack alpha if it is provided. if(length(lambda) == 2){ alpha <- unname(lambda["alpha"]) lambda <- unname(lambda["lambda"]) } else{ alpha <- 1 } # Fit a lasso path (full path for speed, per glmnet documentation) lasso_model <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=alpha) stopifnot(all.equal(class(lasso_model), c("elnet", "glmnet"))) # Get coefficients at the desired lambda. predict.glmnet(exact=TRUE) used to # do this by refitting the whole path augmented with lambda -- including # every grid point BELOW lambda, which warm-started coordinate descent # solves after the target and which therefore cannot influence it. Instead # we fit that augmented grid ourselves, shortened by anchoredLambdaGrid() # and then predicted from with an ordinary exact=FALSE call. The shortened # grid keeps the augmented grid's own final element: predict.glmnet() # interpolates through glmnet:::lambda.interp(), which normalises by # lambda[1] - lambda[k], so the blend weight at lambda depends on the last # supplied grid point as well as the first, and dropping it changes the # answer in its last bits. anchoredLambdaGrid()'s n_interior argument is a # speed constant only; the coefficients here do not depend on it (#125). # The penalty finally predicted at is not lambda but snapLambdaToGrid()'s # reading of it off the fit; the comment at that call says why (#199). # # The short-circuit is a correctness requirement, not an optimisation. # Removing it changes the selected set on the on-grid route -- concentrated # at the top of the path, and by margins far larger than last-bit noise. # css() never reaches it (a subsample's target penalty is essentially never # one of that subsample's own fitted penalties); it is there to keep the # exported direct-call route byte-identical. The predicate is deliberately # the one predict.glmnet() itself applies, match(s, lambda, FALSE), so the # two agree about what "already on the grid" means. if(match(lambda, lasso_model$lambda, 0L) > 0){ fit_at_lambda <- lasso_model } else{ fit_at_lambda <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=alpha, lambda=anchoredLambdaGrid(lasso_model$lambda, lambda)) } # Predict at the penalty this fit actually holds, not at the one we asked # for. glmnet reports a supplied grid back through the response scale -- # divided by it and multiplied by it again -- so the entry that comes back # can sit an ULP away from what went in. predict.glmnet() with a numeric s # does not solve anything: it calls glmnet:::lambda.interp(), which locates # s between two grid columns and returns left, right and frac, and then # forms beta[, left]*frac + beta[, right]*(1 - frac). An ULP miss leaves # frac indistinguishable from 1 or from 0 -- WHICH ONE DEPENDS ON THE SIDE # THE MISS FALLS, measured at path positions 2-5: a miss upward, s above the # fitted entry, leaves frac indistinguishable from 0, and a miss downward # from 1. Do not write this as "a hair short of 1"; that is half the cases. # Either way the nearer entry is the column whose weight is indistinguishable # from 1 -- which follows from lambda.interp()'s construction rather than # only from the sweep -- so every coefficient the OTHER column carries and it # does not is scaled by the complement and SELECTED, because nonzeroCoef()'s # membership test is abs(x) > 0 with no tolerance. The leaked COEFFICIENTS # land around 1e-17; the complement itself is larger, so do not attach that # figure to it. Handing s the fit's own entry makes lambda.interp() report # left == right with frac == 1, so what comes back is the solved column with # its exact zeros (#199). # # Applied on BOTH routes rather than only on the refit route. On the # short-circuit route match(lambda, lasso_model$lambda, 0L) > 0 has already # established an exact hit, so the helper returns lambda unchanged there and # test_that("cssLasso short-circuits when lambda is already on the path # (#125)") stays green with its assertions untouched -- which is how that # claim is confirmed, by running it rather than by asserting it here. s <- snapLambdaToGrid(fit_at_lambda$lambda, lambda) pred <- glmnet::predict.glmnet(fit_at_lambda, type="nonzero", s=s) # predict.glmnet(type="nonzero") has never had a stable container. glmnet # 4.x returned a data.frame whenever apply() could simplify -- i.e. whenever # the per-s index counts were uniform -- and a list otherwise; glmnet >= 5.0 # always returns a list, one element per s value. For the scalar s used here # that rule makes 4.x yield a data.frame on a non-empty selection and a list # on an empty one, but the underlying rule is about simplification, not # emptiness. unlist() flattens every one of those shapes to the same integer # vector, so this is version-agnostic -- it is the idiom glmnet 5.0's own # NEWS prescribes for cross-version callers (#188). # # SAFE HERE ONLY BECAUSE s IS SCALAR, which two things together guarantee: # checkCssLassoInputs() rejects any lambda whose length is not 1 or 2, and # the unpacking above reduces the length-2 c(lambda=, alpha=) form to a # single penalty. (Both halves matter -- cssLasso() is exported, so it can # be called directly.) So pred has exactly one slot and unlist() cannot # union indices across s values. # # Do NOT copy this idiom to a call that leaves s unspecified: predict.glmnet # then returns one slot per penalty in the fitted path. clusterLassoCore() # does exactly that, and flattening its result would silently merge the # per-model-size sets that getClusterSelsFromGlmnet() consumes (#190). stopifnot(!("try-error" %in% class(pred) | "error" %in% class(pred) | "simpleError" %in% class(pred) | "condition" %in% class(pred))) selected_glmnet <- sort(unique(unlist(pred))) # No feature selected at this penalty: unlist() of the all-NULL result is # NULL, hence length 0. Replaces the previous is.null(pred[[1]]) test, which # inspected the container rather than the contents. if(length(selected_glmnet) == 0){ return(integer()) } stopifnot(length(selected_glmnet) <= ncol(X)) stopifnot(all(selected_glmnet == round(selected_glmnet))) # No duplicate check is needed: nonzeroCoef() builds each slot as which[x], # a logical subset of distinct column indices, so duplicates cannot arise # upstream. (Asserting it after unique() would be a guardrail blinded by its # own input rather than a real check.) selected <- as.integer(selected_glmnet) return(selected) } Notice that cssLasso() depends on the package glmnet, and calls the function checkCssLassoInputs(), which verifies that the inputs to cssLasso() are as needed. (In particular, the function css() imposes very few requirements on lambda and y to allow the end user flexibility for any specified fitfun. checkCssLassoInputs() ensures that y is a real-valued response, lambda is a nonnegative real number, etc.) cssLasso() also calls anchoredLambdaGrid(), which builds the short penalty grid the second lasso fit runs over–the grid is chosen so that the coefficients at the target penalty come out bit-identical to the full-path refit, at the price of one extra fit over a much shorter grid: it keeps the path down to the target penalty, a little geometric padding below it, and the path’s own final penalty, which the interpolation reads and which therefore cannot be dropped. Both checkCssLassoInputs() and anchoredLambdaGrid() are specified in the helper functions section later. We add glmnet to the DESCRIPTION file as well: usethis::use_package("glmnet") ## v Adding glmnet to 'Imports' field in DESCRIPTION. ## [ ] Refer to functions with `glmnet::fun()`. Finally, getClusterSelMatrix() is the last significant function called within css(). It takes the information from getSelMatrix(), i.e. whether feature \\(j\\in\\hat S^\\lambda(A_b)\\), and outputs for every cluster \\(C\\) whether \\(C\\cap S^\\lambda(A_b)\\neq\\emptyset\\). #' Get cluster selection matrix #' #' Given a matrix of feature selection indicator variables and a list of #' clusters of features, returns a matrix of cluster indicator variables. #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of formatClusters. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). #' @param res A binary integer matrix. `res[i, j]` = 1 if feature j was selected #' on subsample i and equals 0 otherwise, as in the output of `getSelMatrix()`. #' (That is, each row is a selected set.) #' @return A binary integer matrix with the same number of rows #' as res and length(clusters) columns. Entry i, j is 1 if at least #' one member of cluster j was selected on subsample i, and 0 otherwise. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getClusterSelMatrix <- function(clusters, res){ # Check input checkGetClusterSelMatrixInput(clusters, res) p <- ncol(res) n_clusters <- length(clusters) # Map each feature to its (unique) cluster, then aggregate selections per # cluster in one rowsum pass instead of apply()-ing over all rows once per # cluster (#57). Each feature is in exactly one cluster and every cluster is # non-empty (enforced by checkGetClusterSelMatrixInput -> checkClusters # above), so feat2clus is fully populated and rowsum's groups are exactly # 1:n_clusters. rowsum's reorder=TRUE returns groups in numeric order, so the # rows -- and thus columns after t() -- line up positionally with # names(clusters). feat2clus <- integer(p) for(j in 1:n_clusters){ feat2clus[clusters[[j]]] <- j } clust_counts <- rowsum(t(res), group = feat2clus) # n_clusters x nrow(res) res_n_clusters <- t(clust_counts > 0L) * 1L colnames(res_n_clusters) <- names(clusters) # Check output stopifnot(is.matrix(res_n_clusters)) stopifnot(identical(colnames(res_n_clusters), names(clusters))) stopifnot(all(res_n_clusters %in% c(0, 1))) stopifnot(ncol(res_n_clusters) == length(clusters)) return(res_n_clusters) } The helper function checkGetClusterSelMatrixInput() verifies the inputs to getClusterSelMatrix(). With the above and the helper functions below, the css() function is complete! 3.2 Helper functions Below, we specify some of the helper functions for css(), which are less important for understanding what css() does. The function checkCssInputs() is called at the beginning of the css() function. It confirms that the inputs to css() are as expected. Also, css() allows some flexibility in how the inputs are formatted, and checkCssInputs() converts the inputs into consistent formats for later use. The function checkCssClustersInput() is called within checkCssInputs(), and specifically checks the clusters input. formatClusters() modifies clusters, ensuring every feature appears in exactly one cluster (any unclustered features are put in a “cluster” by themselves). checkFormatClustersInput() verifies the input to formatClusters() for safety (this might seem a little redundant here, but formatClusters() is also called by different functions in this package). checkY() ensures (here and elsewhere) that the provided y is as expected. (In particular, in general the inputted y can be a vector of any type as long as the specified fitfun can handle y appropriately. For some function inputs, y must be a numeric vector. checkY() enforces this, among other things.) checkClusters() verifies that the output of formatClusters() is as expected. getPrototypes() identifies the prototypes of each cluster–the feature within each cluster that has the largest marginal sample correlation with y. identifyPrototype() is the workhorse of getPrototypes(), identifying the prototype given a single cluster. checkSamplingType() ensures that the input sampling_type is as expected. checkB() ensures that the input B is as expected. checkPropFeatsRemove() ensures that the input prop_feats_remove is as expected. The function cssLoop() is called within css(). In particular, it is a helper function needed in order to allow for parallel processing of the feature selection method on each of the subsamples. checkCssLoopOutput() verifies that the output of cssLoop() is as expected. This is particularly important because the user can specify their own feature selection method; checkCssLoopOutput() verifies that the output of the feature selection method is valid, and provides an informative error message if not. checkCssLassoInputs() checks that the inputs to the provided fitfun, cssLasso(), are as needed. anchoredLambdaGrid() builds the penalty grid that cssLasso() fits its second lasso path over, so that the solution at the target penalty is obtained without solving most of the path below it. Most, not all: the grid also retains a few padding penalties and the path’s final one, because the interpolation that reads the solution depends on both endpoints of the grid it is given. checkGetClusterSelMatrixInput() verifies that the input to getClusterSelMatrix() is as expected. Tests are written for all of these functions. To keep this chapter readable as continuous narrative, the tests are collected in the Tests chapters at the end of this document (the Tests part) rather than appearing inline after each function. Because every function is defined before that part, each test still runs only after all of its dependencies have been defined. Several of the entry points below accept either a numeric matrix or a data.frame for the design matrix and share the same coercion logic (convert the data.frame with model.matrix, drop the intercept column, and guard against a column-count change that would invalidate supplied cluster indices). We factor that logic into a single internal helper, coerceDataFrameToMatrix(), so the seven call sites stay in sync. #' Coerce a data.frame design matrix to a numeric matrix #' #' Shared helper for the several entry points that accept either a matrix or #' a data.frame `X`: if `X` is a data.frame, convert it with #' `stats::model.matrix(~ .)` and drop the intercept column. If the column #' count changed and clusters were supplied (which would invalidate the #' cluster indices), error. If `X` is already a numeric matrix it is returned #' unchanged; a non-numeric matrix (e.g. a character matrix) is rejected with #' an error. #' @param X A numeric matrix or a data.frame. #' @param clusters A list of integer vectors (the cluster assignments); the #' column-count guard only fires when `length(clusters) > 0`. #' @param arg_name Character; the name of the argument as it should appear in #' the error message's first sentence. Default "X". #' @param convert_phrase Character; the subject of the "Please convert ___" #' sentence. Defaults to `arg_name`; cssSelect passes "the data.frame X" to #' reproduce its existing message verbatim. #' @return The (possibly coerced) numeric matrix. #' @keywords internal #' @noRd coerceDataFrameToMatrix <- function(X, clusters, arg_name = "X", convert_phrase = arg_name){ if(is.data.frame(X)){ p <- ncol(X) X <- stats::model.matrix(~ ., X) # drop = FALSE: a single non-intercept column must stay a matrix. # Without it a 1-column data.frame collapses to a vector, ncol(X) is # NULL, and the guard below evaluates `... & logical(0)` -> the cryptic # "argument is of length zero" instead of letting the clean downstream # "p >= 2" check fire (#43). X <- X[, colnames(X) != "(Intercept)", drop = FALSE] if(length(clusters) > 0 & (p != ncol(X))){ stop(paste0("When stats::model.matrix converted the provided data.frame ", arg_name, " to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert ", convert_phrase, " to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.")) } } if(!is.numeric(X)){ stop(paste0("The provided ", arg_name, " must be a numeric matrix; storage mode \\"", storage.mode(X), "\\" was provided. If ", arg_name, " came from a data.frame, check for character or factor columns."), call. = FALSE) } X } checkNoNAs() guards a design matrix against missing and non-finite values, before any data.frame coercion: #' Error if a design matrix contains missing or non-finite values #' #' Shared guard for the X-accepting entry points. Checks the ORIGINAL input #' (matrix or data.frame) so a data.frame's NAs are caught before #' coerceDataFrameToMatrix()'s model.matrix() call silently drops NA rows #' (na.action = na.omit). Pairs with coerceDataFrameToMatrix(): call this #' first, then coerce. #' @param X A numeric matrix or a data.frame. #' @param arg_name Character; the argument name as it should appear in the #' error message. Default "X". #' @return Invisibly, `X` (unchanged) -- called for its side effect. #' @keywords internal #' @noRd checkNoNAs <- function(X, arg_name = "X"){ has_na <- any(is.na(X)) has_inf <- if(is.data.frame(X)){ any(vapply(X, function(col) is.numeric(col) && any(is.infinite(col)), logical(1))) } else if(is.numeric(X)){ any(is.infinite(X)) } else { FALSE } if(has_na || has_inf){ stop(paste0("The provided ", arg_name, " must not contain missing (NA) or non-finite (Inf) values; please ", "remove or impute them before calling this function."), call. = FALSE) } invisible(X) } checkFiniteY() guards a response vector against missing and non-finite values, before any lasso entry point fits on it: #' Error if a response vector contains missing or non-finite values #' #' Shared guard for the y-accepting lasso entry points. Requires a numeric #' (or integer) y and rejects any NA/NaN/Inf, so the lasso paths fail fast and #' deterministically (getLassoLambda fits cv.glmnet on a RANDOM subsample, so a #' non-finite y would otherwise error only when the bad value happened to be #' drawn). Mirrors checkNoNAs()'s message for consistency. #' @param y A numeric (real-valued) vector. #' @param arg_name Character; the argument name as it should appear in the #' error message. Default "y". #' @return Invisibly, `y` (unchanged) -- called for its side effect. #' @keywords internal #' @noRd checkFiniteY <- function(y, arg_name = "y"){ if(!(is.numeric(y) | is.integer(y))){ stop(paste0("The provided ", arg_name, " must be a numeric (real-valued) vector."), call. = FALSE) } if(any(!is.finite(y))){ stop(paste0("The provided ", arg_name, " must not contain missing (NA) or non-finite (Inf) values; please ", "remove or impute them before calling this function."), call. = FALSE) } invisible(y) } checkCssInputs(): #' Helper function to confirm that inputs to the function `css()` are as expected, #' and modify inputs if needed #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. #' @param y The response; can be anything that takes the form of an #' n-dimensional vector, with the ith entry corresponding to the ith row of X. #' Typically (and for default fitfun = cssLasso), y should be an n-dimensional #' numeric vector. <<param-lambda>> <<param-clusters>> #' @param fitfun A function; the feature selection function used on each #' subsample by cluster stability selection. This can be any feature selection #' method; the only requirement is that it accepts the arguments (and only the #' arguments) X, y, and lambda and returns an integer vector that is a subset of #' 1:p. For example, fitfun could be best subset selection or forward stepwise #' selection or LARS and lambda could be the desired model size; or fitfun could be the #' elastic net and lambda could be a length-two vector specifying lambda and #' alpha. Default is cssLasso, an implementation of lasso (relying on the R #' package glmnet), where lambda is a nonnegative numeric specifying the L1 #' penalty for the lasso, or a named length-2 vector c(lambda, alpha) for an #' elastic net fit. #' @param sampling_type A character vector; either "SS" or "MB". For "MB", #' all B subsamples are drawn randomly (as proposed by Meinshausen and Bühlmann #' 2010). For "SS", in addition to these B subsamples, the B complementary pair #' subsamples will be drawn as well (see Faletto and Bien 2022 or Shah and #' Samworth 2013 for details). Default is "SS", and "MB" is not supported yet. #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. #' @param prop_feats_remove Numeric; if prop_feats_remove is greater than 0, #' then on each subsample, each feature is randomly dropped from the design #' matrix that is provided to fitfun with probability prop_feats_remove #' (independently across features). That is, in a typical subsample, #' prop_feats_remove*p features will be dropped (though this number will vary). #' This is similar in spirit (but distinct from) extended stability selection #' (Beinrucker et. al. 2016); see their paper for some of the benefits of #' dropping features (besides increasing computational speed and decreasing #' memory requirements). For sampling_type="SS", the features dropped in #' each complementary pair of subsamples are identical in order to ensure that #' the theoretical guarantees of Faletto and Bien (2022) are retained within #' each individual pair of subsamples. (Note that this feature is not #' investigated either theoretically or in simulations by Faletto and Bien #' 2022). Must be between 0 and 1. Default is 0. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in X and y to set aside for model training by the #' function getCssPreds after feature selection. (This will only work if y is #' real-valued, because getCssPreds using ordinary least squares regression to #' generate predictions.) If train_inds is not provided, all of the observations #' in the provided data set will be used for feature selection. #' @param num_cores Optional; an integer. If using parallel processing, the #' number of cores to use for parallel processing (num_cores will be supplied #' internally as the mc.cores argument of parallel::mclapply). #' @return A named list with the following elements: \\item{feat_names}{A #' character vector containing the column names of X (if the provided X #' had column names). If the provided X did not have column names, feat_names #' will be NA.} \\item{X}{The provided X, converted to a matrix if it was #' originally provided as a data.frame, and with feature names removed if they #' had been provided.}\\item{clusters}{A list of integer vectors; each vector #' will contain the indices of a cluster of features. Any duplicated clusters #' provided in the input will be removed (when duplicated clusters carry #' different names, the first occurrence's name is kept).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssInputs <- function(X, y, lambda, clusters, fitfun, sampling_type, B, prop_feats_remove, train_inds, num_cores){ stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) feat_names <- as.character(NA) if(!is.null(colnames(X))){ feat_names <- colnames(X) } n <- nrow(X) p <- ncol(X) if(!is.null(colnames(X))){ feat_names <- colnames(X) } stopifnot(p >= 2) if(length(feat_names) > 1){ stopifnot(length(feat_names) == p) } else{ stopifnot(is.na(feat_names)) } colnames(X) <- character() stopifnot(length(y) == n) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. # Check clusters argument clusters <- checkCssClustersInput(clusters) # Derive cluster names AFTER checkCssClustersInput (which may drop duplicate # clusters), so the names line up with the deduplicated list passed to # formatClusters below (#156). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } ### Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clusters <- formatClusters(clusters, p=p, clust_names=clust_names)$clusters stopifnot(class(fitfun) == "function") stopifnot(length(fitfun) == 1) if(!setequal(names(formals(fitfun)), c("X", "y", "lambda"))){ err_mess <- paste("fitfun must accept exactly the arguments X, y, and lambda (in any order, with or without defaults). Detected arguments to fitfun:", paste(names(formals(fitfun)), collapse=", ")) stop(err_mess) } checkSamplingType(sampling_type) checkB(B) checkPropFeatsRemove(prop_feats_remove, p) stopifnot(is.numeric(train_inds) | is.integer(train_inds)) if(length(train_inds) > 0){ stopifnot(all(!is.na(train_inds))) stopifnot(all(round(train_inds) == train_inds)) stopifnot(length(train_inds) == length(unique(train_inds))) stopifnot(all(train_inds >= 1)) stopifnot(all(train_inds <= n)) stopifnot(length(train_inds) <= n - 2) stopifnot(length(train_inds) >= 1) } stopifnot(length(num_cores) == 1) stopifnot(is.integer(num_cores) | is.numeric(num_cores)) stopifnot(!is.na(num_cores)) stopifnot(num_cores == round(num_cores)) stopifnot(num_cores >= 1) n_cores_avail <- parallel::detectCores() # detectCores() returns NA when the count is indeterminable; only enforce the # upper bound when it is known, so an NA does not brick every css() call (#155c). if(!is.na(n_cores_avail)){ stopifnot(num_cores <= n_cores_avail) } return(list(feat_names=feat_names, X=X, clusters=clusters)) } checkCssClustersInput: #' Helper function to confirm that clusters input to css is as expected #' <<param-clusters>> #' @return Same as the input, but all of the clusters will be coerced to #' integers. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssClustersInput <- function(clusters){ stopifnot(!is.na(clusters)) if(is.list(clusters)){ stopifnot(all(!is.na(clusters))) if(length(clusters) > 0){ for(i in 1:length(clusters)){ stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(is.integer(clusters[[i]]) | is.numeric(clusters[[i]])) stopifnot(all(clusters[[i]] == round(clusters[[i]]))) stopifnot(all(clusters[[i]] >= 1)) clusters[[i]] <- as.integer(clusters[[i]]) } # Remove exact-duplicate clusters (documented behavior; keeps the first # occurrence, so its name wins). Distinct-but-overlapping clusters are # still rejected by the overlap check below (#156). clusters <- clusters[!duplicated(clusters)] if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ if(length(intersect(clusters[[i]], clusters[[j]])) != 0){ error_mes <- paste("Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: ", i, ", ", j, ".", sep="") stop(error_mes) } } } } } } else{ # If clusters is not a list, it should be a vector of indices of # features that are in the (one) cluster stopifnot(is.numeric(clusters) | is.integer(clusters)) stopifnot(length(clusters) == length(unique(clusters))) stopifnot(all(!is.na(clusters))) stopifnot(is.integer(clusters) | is.numeric(clusters)) stopifnot(all(clusters == round(clusters))) stopifnot(all(clusters >= 1)) clusters <- as.integer(clusters) } return(clusters) } formatClusters(): #' Formats clusters in standardized way, optionally estimating cluster #' prototypes #' #' @param clusters Either an integer vector of a list of integer vectors; each #' vector should contain the indices of a cluster of features. (If there is only #' one cluster, clusters can either be a list of length 1 or simply an integer #' vector.) If clusters is specified then R is ignored. #' @param p integer or numeric; the numbe of features in x (should match #' ncol(x), if x is provided) #' @param clust_names A character vector of the names of the clusters in #' clusters. #' @param get_prototypes Logical: if TRUE, will identify prototype from each #' cluster (the feature from each cluster that is most correlated with the #' response) for the protolasso. In this case, x and y must be provided. #' @param x n x p numeric matrix; design matrix. Only needs to be provided if #' get_prototypes is TRUE. #' @param y Numeric response vector; only needs to be provided if get_prototypes #' is TRUE. Note: in general, the css function does not require y to be a #' numeric vector, because the provided fitfun could use a different form of y #' (for example, a categorical response variable). However, y must be numeric in #' order to provide prototypes because the prototypes are determined using the #' correlation between cluster members (columns of x) and y. #' @param R Numeric p x p matrix; not currently used. Entry ij contains the #' "substitutive value" of feature i for feature j (diagonal must consist of #' ones, all entries must be between 0 and 1, and matrix must be symmetric) #' @return A named list with the following elements: \\item{clusters}{A named #' list where each entry is an integer vector of indices of features that are in #' a common cluster. (The length of list clusters is equal to the number of #' clusters.) All identified clusters are non-overlapping. All features appear #' in exactly one cluster (any unclustered features will be put in their own #' "cluster" of size 1).} \\item{multiple}{Logical; TRUE if there is more than #' one cluster of size greater than 1, FALSE otherwise.} \\item{prototypes}{only #' returned if get_prototypes=TRUE. An integer vector whose length is equal to #' the number of clusters. Entry i is the index of the feature belonging to #' cluster i that is most highly correlated with y (that is, the prototype for #' the cluster, as in the protolasso; see Reid and Tibshirani 2016).} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd formatClusters <- function(clusters=NA, p=-1, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA){ # Check inputs clusters <- checkFormatClustersInput(clusters, p, clust_names, get_prototypes, x, y, R) n <- nrow(x) multiple <- FALSE if(any(lengths(clusters) > 1)){ # & length(clusters) > 1 # Only care about clusters with more than one element (only ones that # need to be treated differently) # keep track of whether there's more than one cluster or not multiple <- sum(lengths(clusters) > 1) > 1 } # For any features not already in a cluster, add a cluster containing only # that feature orig_length_clusters <- length(clusters) stopifnot(p >= 1) for(i in 1:p){ feat_i_found <- FALSE if(orig_length_clusters > 0){ for(j in 1:orig_length_clusters){ # If i is in cluster j, break out of this loop and consider the # next i if(i %in% clusters[[j]]){ feat_i_found <- TRUE break } } } # If feature i wasn't found in any cluster, add a cluster containing # just feature i if(!feat_i_found){ clusters[[length(clusters) + 1]] <- i } } n_clusters <- length(clusters) # Add names to clusters if(is.null(names(clusters))){ names(clusters) <- paste("c", 1:n_clusters, sep="") } else{ # What clusters need names? unnamed_clusts <- which(is.na(names(clusters)) | names(clusters) == "") if(length(unnamed_clusts) > 0){ proposed_clust_names <- paste("c", unnamed_clusts, sep="") # Replace any proposed cluster names that are already in use if(any(proposed_clust_names %in% names(clusters))){ proposed_clust_names[proposed_clust_names %in% names(clusters)] <- paste("c", unnamed_clusts[proposed_clust_names %in% names(clusters)] + p, sep="") } while_counter <- 0 while(any(proposed_clust_names %in% names(clusters))){ proposed_clust_names[proposed_clust_names %in% names(clusters)] <- paste(proposed_clust_names[proposed_clust_names %in% names(clusters)], "_1", sep="") while_counter <- while_counter + 1 if(while_counter >= 100){ stop("Function formatClusters stuck in an infinite while loop") } } stopifnot(length(unnamed_clusts) == length(proposed_clust_names)) names(clusters)[unnamed_clusts] <- proposed_clust_names } } # Check output checkClusters(clusters, p) stopifnot(is.logical(multiple)) stopifnot(length(multiple) == 1) stopifnot(!is.na(multiple)) if(get_prototypes){ prototypes <- getPrototypes(clusters, x, y) return(list(clusters=clusters, multiple=multiple, prototypes=prototypes)) } else{ return(list(clusters=clusters, multiple=multiple)) } } checkFormatClustersInput(): #' Helper function to ensure that the inputs to formatClusters are as expected #' #' @param clusters Either an integer vector of a list of integer vectors; each #' vector should contain the indices of a cluster of features. (If there is only #' one cluster, clusters can either be a list of length 1 or simply an integer #' vector.) If clusters is specified then R is ignored. #' @param p integer or numeric; the numbe of features in x (should match #' ncol(x), if x is provided) #' @param clust_names A character vector of the names of the clusters in clusters. #' @param get_prototypes Logical: if TRUE, will identify prototype from each #' cluster (the feature from each cluster that is most correlated with the #' response) for the protolasso. In this case, x and y must be provided. #' @param x n x p numeric matrix; design matrix. Only needs to be provided if #' get_prototypes is TRUE. #' @param y Numeric response vector; only needs to be provided if get_prototypes #' is TRUE. Note: in general, the css function does not require y to be a #' numeric vector, because the provided fitfun could use a different form of y #' (for example, a categorical response variable). However, y must be numeric in #' order to provide prototypes because the prototypes are determined using the #' correlation between cluster members (columns of x) and y. #' @param R Numeric p x p matrix; not currently used. Entry ij contains the #' "substitutive value" of feature i for feature j (diagonal must consist of #' ones, all entries must be between 0 and 1, and matrix must be symmetric) #' @return A list of integer vectors; each vector will contain the indices of a #' cluster of features. Any duplicated clusters provided in the input will be #' removed (when duplicated clusters carry different names, the first #' occurrence's name is kept). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkFormatClustersInput <- function(clusters, p, clust_names, get_prototypes, x, y, R){ if(any(is.na(clusters)) & any(is.na(R))){ stop("Must specify one of clusters or R (or does one of these provided inputs contain NA?)") } stopifnot(is.integer(p) | is.numeric(p)) stopifnot(length(p) == 1) stopifnot(p == round(p)) stopifnot(!is.na(p)) if(p > 0){ stopifnot(p >= 2) } use_R <- FALSE if(any(is.na(clusters)) | length(clusters) == 0){ if(all(!is.na(R))){ stopifnot(is.matrix(R)) stopifnot(all(dim(R) == p)) stopifnot(all(diag(R) == 1)) stopifnot(identical(R, t(R))) stopifnot(all(!is.na(R))) stopifnot(all(R %in% c(0, 1))) use_R <- TRUE } } else{ stopifnot(!is.list(clusters) | all(lengths(clusters) >= 1)) stopifnot(is.list(clusters) | length(clusters) >= 1) stopifnot(all(!is.na(clusters))) if(is.list(clusters) & length(clusters) > 0){ for(i in 1:length(clusters)){ stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(all(clusters[[i]] >= 1)) stopifnot(is.integer(clusters[[i]])) } if(any(!is.na(clust_names))){ stopifnot(length(clust_names) == length(clusters)) } clusters <- clusters[!duplicated(clusters)] if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ stopifnot(length(intersect(clusters[[i]], clusters[[j]])) == 0) } } } } else if(!is.list(clusters)){ clusters_temp <- clusters clusters <- list() clusters[[1]] <- clusters_temp rm(clusters_temp) } } stopifnot(length(get_prototypes) == 1) stopifnot(is.logical(get_prototypes)) if(any(!is.na(clust_names))){ stopifnot(is.character(clust_names)) } if(get_prototypes){ stopifnot(all(!is.na(x))) stopifnot(is.matrix(x)) n <- nrow(x) checkY(y, n) } if(use_R){ # Determine clusters from R clusters <- list() for(i in 1:nrow(R)){ clusters[[i]] <- as.integer(which(R[i, ] > 0)) stopifnot(length(clusters[[i]]) == length(unique(clusters[[i]]))) stopifnot(all(!is.na(clusters[[i]]))) stopifnot(is.integer(clusters[[i]])) } clusters <- unique(clusters) stopifnot(is.list(clusters)) if(length(clusters) >= 2){ # Check that clusters are non-overlapping for(i in 1:(length(clusters) - 1)){ for(j in (i+1):length(clusters)){ if(length(intersect(clusters[[i]], clusters[[j]])) != 0){ stop("Invalid R matrix with overlapping clusters (clusters must not be overlapping)") } } } } } # Bounds-check cluster indices against p now that clusters has been # normalized to a list (covers list, bare-vector, and R-derived clusters). # Guarded by p > 0 because formatClusters defaults p = -1 (a sentinel that # disables the p-dependent checks); seq_along is empty for an empty clusters # and any NA-containing input has already errored at the top of this # function, so every element here is a non-empty integer vector. if(p > 0){ for(i in seq_along(clusters)){ if(any(clusters[[i]] > p)){ stop(paste0("Cluster index ", max(clusters[[i]]), " exceeds the number of features (p = ", p, ")."), call. = FALSE) } } } stopifnot(is.list(clusters)) return(clusters) } checkY(): #' Helper function to confirm that the argument y to several functions is #' as expected #' #' @param y Numeric response vector. #' @param n Number of observations of covariates; should match length of y. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkY <- function(y, n){ stopifnot(all(is.finite(y))) stopifnot(is.numeric(y) | is.integer(y)) stopifnot(length(unique(y)) > 1) stopifnot(length(n) == 1) stopifnot(!is.na(n)) stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n > 0) stopifnot(n == length(y)) } checkClusters(): #' Helper function to confirm that the argument clusters to several functions is #' as expected #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of css or #' formatClusters. (The length of list clusters is equal to the number of #' clusters.) All identified clusters must be non-overlapping, and all features #' must appear in exactly one cluster (any unclustered features should be in #' their own "cluster" of size 1). #' @param p The number of features; must be at least as large as the number of #' clusters. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkClusters <- function(clusters, p){ stopifnot(is.list(clusters)) stopifnot(all(lengths(clusters) >= 1)) stopifnot(all(!is.na(clusters))) n_clusters <- length(clusters) stopifnot(n_clusters == length(unique(clusters))) stopifnot(n_clusters <= p) stopifnot(!is.null(names(clusters))) stopifnot(is.character(names(clusters))) stopifnot(all(!is.na(names(clusters)) & names(clusters) != "")) stopifnot(length(unique(names(clusters))) == n_clusters) all_clustered_feats <- integer() for(i in 1:n_clusters){ stopifnot(is.integer(clusters[[i]])) all_clustered_feats <- c(all_clustered_feats, clusters[[i]]) } stopifnot(length(all_clustered_feats) == p) stopifnot(length(unique(all_clustered_feats)) == p) stopifnot(all(all_clustered_feats <= p)) stopifnot(all(all_clustered_feats >= 1)) } getPrototypes(): #' Estimate prototypes from a list of clusters #' #' Takes in list of clusters, x, and y and returns an integer vector (of length #' equal to the number of clusters) of the indices of the feature prototypes #' (the features from each cluster most correlated with the response). #' #' @param clusters A list where each entry is an integer vector of indices of #' features that are in a common cluster. (The length of list clusters must be #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. Must only include clusters of size 2 or larger. #' @param x n x p numeric matrix; design matrix. #' @param y Numeric response vector. Note: in general, the css function does not #' require y to be a numeric vector, because the provided fitfun could use a #' different form of y (for example, a categorical response variable). However, #' y must be numeric in order to provide prototypes because the prototypes are #' determined using the correlation between cluster members (columns of x) and #' y. #' @return An integer vector of the same length as clusters. Entry j is the #' index of the feature identified as the prototype for cluster j. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getPrototypes <- function(clusters, x, y){ # Check inputs stopifnot(!is.list(clusters) | all(lengths(clusters) >= 1)) stopifnot(is.list(clusters) | length(clusters) >= 1) stopifnot(all(!is.na(x))) stopifnot(is.matrix(x)) n <- nrow(x) p <- ncol(x) checkY(y, n) # Identify prototypes if(length(clusters) > 0){ if(is.list(clusters)){ prototypes <- rep(as.integer(NA), length(clusters)) for(i in 1:length(clusters)){ prototypes[i] <- identifyPrototype(clusters[[i]], x, y) } } else{ # If clusters is not a list, then there is only one cluster. prototypes <- identifyPrototype(clusters, x, y) } } else{ prototypes <- integer() } # Check output stopifnot(is.integer(prototypes)) if(length(clusters) > 0){ if(is.list(clusters)){ stopifnot(length(prototypes) == length(clusters)) } else { stopifnot(length(prototypes) == 1) } } else{ stopifnot(length(prototypes) == 0) } stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) return(prototypes) } identifyPrototype(): #' Estimate prototypes from a single cluster #' #' Takes in a single cluster, x, and y and returns an integer of the index of #' the feature prototype (the feature from the cluster most correlated with the #' response). #' #' @param cluster_members_i An integer vector of indices of features that are in #' a common cluster. Must have length at least 2. #' @param x n x p numeric matrix; design matrix. #' @param y Numeric response vector. Note: in general, the css function does not #' require y to be a numeric vector, because the provided fitfun could use a #' different form of y (for example, a categorical response variable). However, #' y must be numeric in order to provide prototypes because the prototypes are #' determined using the correlation between cluster members (columns of x) and #' y. #' @return integer; the index of the feature identified as the prototype for #' the cluster. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd identifyPrototype <- function(cluster_members_i, x, y){ # Check input stopifnot(is.integer(cluster_members_i)) # If cluster only has one member, that member is the prototype if(length(cluster_members_i) == 1){ return(cluster_members_i) } # Choose which cluster member to represent cluster for stability # metric purposes by choosing the one most highly correlated # with y # All cluster-member correlations in one cor() call. A constant column (or # constant y) has undefined correlation -> treat as 0. (A whole-matrix # cor() can differ from a per-column loop in the last ULP and so flip # which.max on a near-tie -> a different but equally-valid prototype.) if(length(unique(y)) == 1){ warning("identifyPrototype: the response y has only one unique value") } # suppressWarnings: base cor() emits "the standard deviation is zero" for a # constant column; we want a silent 0 there, so muffle ONLY the cor() call # (the explicit constant-y warning above is kept). cors_i <- suppressWarnings(abs(stats::cor(x[, cluster_members_i, drop = FALSE], y))) cors_i <- as.numeric(cors_i) cors_i[is.na(cors_i)] <- 0 max_index_i <- which.max(cors_i)[1] stopifnot(length(max_index_i) == 1) stopifnot(max_index_i %in% 1:length(cluster_members_i)) ret <- cluster_members_i[max_index_i] # Check output stopifnot(is.integer(ret)) stopifnot(length(ret) == 1) stopifnot(ret %in% cluster_members_i) # (#129) Dropped a tautological assert here: ret == cluster_members_i[ # max_index_i], so x[, cluster_members_i][, max_index_i] is by construction # x[, ret]. The check could never fire, but it materialized a fresh # n x |cluster| submatrix copy of x on every prototype identification. return(ret) } checkSamplingType(): #' Helper function to confirm that the argument sampling_type to several #' functions is as expected #' #' @param sampling_type A character vector; either "SS" or "MB". "MB" is not #' supported yet. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkSamplingType <- function(sampling_type){ stopifnot(is.character(sampling_type)) stopifnot(length(sampling_type) == 1) stopifnot(!is.na(sampling_type)) stopifnot(sampling_type %in% c("SS", "MB")) if(sampling_type == "MB"){ stop("sampling_type MB is not yet supported (and isn't recommended anyway)") } } checkB(): #' Helper function to confirm that the argument B to several functions is as #' expected #' #' @param B Integer or numeric; the number of subsamples. For #' `sampling_type="SS"` the number of subsamples will be `2*B`. Default is 50. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkB <- function(B){ stopifnot(length(B) == 1) stopifnot(is.numeric(B) | is.integer(B)) stopifnot(!is.na(B)) stopifnot(B == round(B)) stopifnot(B > 0) if(B < 10){ warning("Small values of B may lead to poor results.") } else if (B > 2000){ warning("Large values of B may require long computation times.") } } checkAlpha(): #' Confirm that the elastic-net mixing parameter alpha is as expected #' #' Shared validator for the alpha argument of getLassoLambda, getModelSize, #' cssSelect, and cssPredict: a single number in (0, 1] (alpha = 1 is the #' lasso). Factored out of those four functions, which each held a verbatim #' copy, so they cannot drift (#72). #' @param alpha Numeric or integer; the elastic-net mixing parameter. Must be #' length 1, non-NA, and in (0, 1]. #' @return No return value; called for the side effect of erroring on bad #' input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkAlpha <- function(alpha){ stopifnot(is.numeric(alpha) | is.integer(alpha)) stopifnot(length(alpha) == 1) stopifnot(!is.na(alpha)) stopifnot(alpha > 0) stopifnot(alpha <= 1) } checkPropFeatsRemove(): #' Helper function to confirm that the argument prop_feats_remove to several #' functions is as expected #' #' @param prop_feats_remove Numeric; proportion of features that are dropped on #' each subsample. Must be between 0 and 1. #' @param p The number of features; must be greater than 2 if prop_feats_remove #' is greater than 0. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkPropFeatsRemove <- function(prop_feats_remove, p){ stopifnot(length(prop_feats_remove) == 1) stopifnot(is.numeric(prop_feats_remove) | is.integer(prop_feats_remove)) stopifnot(!is.na(prop_feats_remove)) stopifnot(prop_feats_remove >= 0 & prop_feats_remove < 1) if(prop_feats_remove > 0){ # Make sure p is at least 2 or else this doesn't make sense stopifnot(p >= 2) } } cssLoop(): #' Helper function run on each subsample #' #' Runs provided feature selection method `fitfun` on each subsample for cluster #' stability selection (this function is called within `mclapply`). #' @param input Could be one of two things: #' - `subsample`: An integer vector of size `n/2` containing the indices of the #' observations in the subsample. #' - `drop_var_input`: A named list containing two elements: one named #' "subsample" and the same as the previous description, and a logical vector #' named "feats_to_keep" containing the indices of the features to be #' automatically selected. #' #' (The first object is the output of the function `createSubsamples()` when the #' provided `prop_feats_remove` is 0, the default, and the second object is the #' output of `createSubsamples()` when `prop_feats_remove > 0`.) #' @param x an n x p numeric matrix containing the predictors. (This should be #' the full design matrix provided to css.) #' @param y A response; can be any response that takes the form of a length n #' vector and is used (or not used) by `fitfun`. Typically (and for default #' `fitfun = cssLasso`), `y` should be an n-dimensional numeric vector containing the #' response. This should be the full response provided to css. #' @param lambda A tuning parameter or set of tuning parameters that may be used #' by the feature selection method. For example, in the default case when #' `fitfun = cssLasso`, `lambda` is a numeric: the penalty to use for each lasso #' fit. #' @param fitfun A function that takes in arguments X, y, and lambda and returns #' a vector of indices of the columns of X (selected features). #' @param seed Optional integer. If non-NULL, the random number generator is #' seeded with `set.seed(seed)` immediately before `fitfun` is called, so that a #' stochastic `fitfun` is reproducible and identical across serial and parallel #' execution. Default NULL (no seeding). Supplied internally by `getSelMatrix` #' (one reproducible seed per subsample); direct callers can leave it NULL. #' @return An integer vector; the indices of the features selected by `fitfun`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd cssLoop <- function(input, x, y, lambda, fitfun, seed=NULL){ # Check inputs stopifnot(is.matrix(x)) # NOTE: x is intentionally NOT re-scanned for NAs here. cssLoop is @noRd and # called only by getSelMatrix (via mclapply), which already validates that # the full x is NA-free once before the 2*B-subsample loop. Re-scanning the # whole n x p matrix every subsample was ~5s of pure redundant work at # n=p=2000 (#60); the upstream check makes it unnecessary on every reachable # path. colnames(x) <- character() n <- nrow(x) p <- ncol(x) stopifnot(length(y) == n) stopifnot(!is.matrix(y)) # Intentionally don't check y or lambda further to allow for flexibility--these # inputs should be checked within fitfun. if(!is.list(input)){ subsample <- input feats_to_keep <- rep(TRUE, p) } else{ stopifnot(all(names(input) == c("subsample", "feats_to_keep"))) subsample <- input$subsample feats_to_keep <- input$feats_to_keep } stopifnot(is.integer(subsample)) stopifnot(all(subsample == round(subsample))) stopifnot(floor(n/2) == length(subsample)) stopifnot(length(subsample) == length(unique(subsample))) stopifnot(is.logical(feats_to_keep)) stopifnot(length(feats_to_keep) == p) # Seed immediately before fitfun so a stochastic fitfun is reproducible # across serial/parallel execution (issue #12). seed is NULL for the # deterministic default cssLasso path and for direct callers. if(!is.null(seed)){ set.seed(seed) } selected <- do.call(fitfun, list(X=x[subsample, feats_to_keep], y=y[subsample], lambda=lambda)) # Validate the RAW fitfun return against its documented contract (an # integer vector that is a subset of seq_len(p_sub), where p_sub is the # number of columns handed to fitfun) BEFORE remapping to original # feature indices. Remapping first -- which(feats_to_keep)[selected] -- # would let R's index arithmetic silently turn contract violations # (negative, logical, fractional, or NULL returns) into # plausible-but-wrong selections (#151). p_sub <- sum(feats_to_keep) checkCssLoopOutput(selected, p_sub, seq_len(p_sub)) selected <- which(feats_to_keep)[as.integer(selected)] # Defensive post-remap check: once the raw return validates and the # remap is a plain index lookup, the remapped indices are guaranteed a # valid subset of the original features -- but keep the check as cheap # insurance at the user-code boundary. checkCssLoopOutput(selected, p, as.integer(which(feats_to_keep))) return(as.integer(selected)) } checkCssLoopOutput(): #' Helper function to confirm that the outputs of the provided feature selection #' method are as required. #' #' @param selected An integer vector; the indices of the features selected by #' the lasso. #' @param p The total number of observed features; all selected features must be #' in 1:p. #' @param feats_on_subsamp Integer; the indices of the features considered by #' the feature selection method. All selected features must be among these #' features. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssLoopOutput <- function(selected, p, feats_on_subsamp){ if(is.null(selected)){ stop("The provided feature selection method fitfun returned NULL on (at least) one subsample; to select no features, return integer(0).") } if(is.logical(selected)){ stop("The provided feature selection method fitfun returned a logical vector on (at least) one subsample; it must return integer indices of the selected features (e.g. which(coef != 0)).") } if(!is.integer(selected) & !is.numeric(selected)){ stop("The provided feature selection method fitfun failed to return an integer or numeric vector on (at least) one subsample") } if(any(is.na(selected))){ stop("The provided feature selection method fitfun returned a vector containing NA values on (at least) one subsample") } if(!all(selected == round(selected))){ stop("The provided feature selection method fitfun failed to return a vector of valid (integer) indices on (at least) one subsample") } if(length(selected) != length(unique(selected))){ stop("The provided feature selection method fitfun returned a vector of selected features containing repeated indices on (at least) one subsample") } if(length(selected) > p){ stop("The provided feature selection method fitfun returned a vector of selected features longer than p on (at least) one subsample") } if(length(selected) > 0){ if(max(selected) > p){ stop("The provided feature selection method fitfun returned a vector of selected features containing an index greater than ncol(X) on (at least) one subsample") } if(min(selected) <= 0){ stop("The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample") } } if("try-error" %in% class(selected) | "error" %in% class(selected) | "simpleError" %in% class(selected) | "condition" %in% class(selected)){ stop("The provided feature selection method fitfun returned an error on (at least) one subsample") } if(!all(selected %in% feats_on_subsamp)){ stop("The provided feature selection method somehow selected features that were not provided for it to consider.") } } fitfunFailureMessage() builds the informative error that getSelMatrix() raises when a subsample’s fitfun result is not a valid integer vector. getSelMatrix() wraps each subsample’s cssLoop() call in a tryCatch() that tags a failure with its true subsample index as a cssr_loop_error, so a fitfun error is reported the same way whether the run is serial or parallel (and prescheduling can no longer misattribute it to the wrong subsample); the try-error branch is a defensive fallback: #' Build an informative error for a subsample whose fitfun result is invalid #' #' Reached when cssLoop failed on a subsample. getSelMatrix wraps each #' subsample's cssLoop call in a tryCatch that tags the failure with its true #' subsample index as a cssr_loop_error (on both the serial and parallel paths), #' so the message names the correct subsample rather than a #' prescheduling-misattributed one. Surfaces the underlying cause in the error #' condition rather than printing it to stdout. #' @param result The offending element of getSelMatrix's res_list (normally a #' cssr_loop_error carrying the tagged subsample index and message; the #' try-error and class branches are defensive fallbacks). #' @param i Integer; the loop index of the subsample that failed (used only by #' the fallback branches -- a cssr_loop_error carries its own tagged index). #' @return A length-one character string suitable for stop(). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd fitfunFailureMessage <- function(result, i){ if(inherits(result, "cssr_loop_error")){ return(paste0("The feature selection method (fitfun) failed on subsample ", result$i, ": ", result$msg)) } if(inherits(result, "try-error")){ paste0("The feature selection method (fitfun) failed on subsample ", i, ": ", conditionMessage(attr(result, "condition"))) } else{ paste0("The feature selection method (fitfun) returned an object of ", "class ", paste(class(result), collapse = "/"), " on subsample ", i, "; it must return an integer vector of selected feature indices.") } } A small platform helper lets css() decide whether parallel forking is available. It is factored out (rather than inlined) so the Windows fallback can be exercised on non-Windows machines in the tests: #' Is the current session running on Windows? #' #' parallel::mclapply relies on forking, which is unavailable on Windows; css() #' uses this to downgrade num_cores > 1 to serial there rather than let mclapply #' hard-error (#155d). Factored into a helper so the Windows branch is #' unit-testable off-Windows via local_mocked_bindings. #' @return TRUE if running on Windows, FALSE otherwise. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd runningOnWindows <- function(){ identical(.Platform$OS.type, "windows") } checkCssLassoInputs(): #' Helper function to confirm that the inputs to `cssLasso()` are as expected. #' #' @param X A design matrix containing the predictors. (Note that we don't need #' to check X very much, because X will have already been checked by the #' function `checkCssInputs()` when it was provided to `css()`.) #' @param y A numeric vector containing the response. #' @param lambda Either a single nonnegative number for the lasso penalty to #' use on each subsample, or a named length-2 numeric vector #' `c(lambda = <value>, alpha = <value>)` bundling the penalty together with the #' elastic net mixing parameter alpha (which must be in `(0, 1]`). (For now, #' only one lambda value can be provided to `cssLasso()`; in the future, we plan #' to allow for multiple lambda values to be provided to `cssLasso()`, as #' described in Faletto and Bien 2022.) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCssLassoInputs <- function(X, y, lambda){ n <- nrow(X) p <- ncol(X) if(!is.numeric(y) & !is.integer(y)){ stop("For method cssLasso, y must be a numeric or integer vector.") } if(any(!is.finite(y))){ stop("For method cssLasso, y must not contain missing (NA) or non-finite (Inf) values.") } if(is.matrix(y)){ stop("For method cssLasso, y must be a numeric vector (inputted y was a matrix).") } if(n != length(y)){ stop("For method cssLasso, y must be a vector of length equal to nrow(X).") } if(length(unique(y)) <= 1){ stop("Subsample with only one unique value of y detected: for the default cssLasso, every subsample of y (of size floor(n/2)) must have more than one unique value. css draws random subsamples, so this abort is seed-dependent and becomes more likely as B grows. It indicates that y is too discrete for the default cssLasso--supply a less discrete (more continuous) response, or pass a custom fitfun that tolerates a constant-y subsample.") } if(!is.numeric(lambda) & !is.integer(lambda)){ stop("For method cssLasso, lambda must be a numeric.") } if(any(is.na(lambda))){ stop("NA detected in provided lambda input to cssLasso") } # lambda may be either a single nonnegative number (pure lasso) or a named # length-2 numeric vector c(lambda=<value>, alpha=<value>) bundling the # elastic net mixing parameter alpha (in (0, 1]) alongside the penalty. if(length(lambda) == 1){ if(lambda < 0){ stop("For method cssLasso, lambda must be nonnegative.") } } else if(length(lambda) == 2){ if(!setequal(names(lambda), c("lambda", "alpha"))){ stop("For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).") } if(lambda["lambda"] < 0){ stop("For method cssLasso, the lambda component of lambda must be nonnegative.") } if(lambda["alpha"] <= 0 | lambda["alpha"] > 1){ stop("For method cssLasso, the alpha component of lambda must be in (0, 1].") } } else{ stop("For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).") } } anchoredLambdaGrid() builds the penalty grid that cssLasso()’s second glmnet fit runs over, replacing the full-path refit that predict.glmnet(exact = TRUE) used to perform internally (#125): #' Build an anchored, padded lambda grid for a second glmnet fit #' #' Returns a shortened version of the augmented penalty grid #' `unique(rev(sort(c(s, lambda_path))))` that `predict.glmnet(exact = TRUE)` #' refits over: that grid's prefix through one element past `s`, a few #' geometrically spaced interior points, and that grid's own final element #' re-appended. `cssLasso()` fits over this instead of over the whole augmented #' grid. The comments in the body say why the first and last elements are #' carried over unchanged, why each guard is there, and which test block #' enforces the construction. #' #' @param lambda_path A numeric vector of penalties (in practice the `$lambda` #' component of a fitted `glmnet` object). This is a requirement on the caller #' rather than a claim about what `glmnet()` returns: because the interior #' points are spaced in log space, `lambda_path` must not contain a zero unless #' `s` is at or below its smallest positive entry. Any other path containing a #' zero takes `log(0)` and errors in `seq()`; nothing checks it at runtime. #' @param s The target penalty; a single nonnegative number. #' @param n_interior The number of geometrically spaced interior points padding #' the gap below `s`. This is a speed constant and not a correctness one: the #' coefficients the returned grid yields at `s` do not depend on it, and 5 was #' chosen by end-to-end timing of `css()`, in particular for the n < p corner #' where 0 interior points is a net loss. Changing it changes speed only. #' @return A strictly decreasing numeric vector with no duplicated entries, #' whose first and last elements are `identical()` to those of #' `unique(rev(sort(c(s, lambda_path))))`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd anchoredLambdaGrid <- function(lambda_path, s, n_interior=5L){ # g_full is the grid predict.glmnet(exact=TRUE) refits over -- the fitted # path augmented with s, de-duplicated and ordered decreasing. The # expression is glmnet's own operator for operator, so both sides drop NA and # NaN (sort() keeps +-Inf) and collapse repeats identically. g_full <- unique(rev(sort(c(s, lambda_path)))) k_full <- length(g_full) # glmnet walks a grid in decreasing order with each solution warm-starting # the next, so the solution at s depends only on penalties at or above s; # kt counts those. The prefix is kept through one element PAST s because # predict.glmnet interpolates between s's two neighbours in the grid, and # that extra element is the one lambda.interp() calls `right` -- the next # penalty DOWN, since the grid is ordered decreasing. The min() caps the index # for the case where kt already reaches the end of g_full and there is no # further element to keep -- s = 0, and any s at or below min(lambda_path). kt <- sum(g_full >= s) keep <- g_full[1:min(k_full, kt + 1L)] lo <- g_full[k_full] hi <- keep[length(keep)] # Two cases have no gap to pad: n_interior <= 0, the caller asking for no # padding, and hi <= lo, keep already reaching the end of g_full. That is a # wider set than the min() cap above: it holds whenever s is the smallest or # the SECOND smallest element of g_full, so a user penalty falling between # the two smallest fitted ones also lands here and gets the augmented grid # unshortened, which is correct and saves nothing. This guard is also what # keeps log(0) out of the seq() below on a degenerate glmnet path, which is # a case that genuinely occurs rather than a hypothetical one. The condition # is max(abs(crossprod(X, y))) == 0 EXACTLY -- not merely an orthogonal # design, and not a numerically small value: measured, an orthonormal X with # a generic y gives an ordinary path, and so does one with max|X'y| at 1e-16. # At exact zero glmnet returns NaN followed by zeros for $lambda; sort() then # drops the NaN and unique() collapses the zeros, leaving a g_full of two # elements that lands here. Pinned end to end by # test_that("cssLasso survives a degenerate lasso path (#125)"), which drives # such a design through cssLasso() and asserts an empty selection rather than # an error. Note that the repo's older #157 fixture does NOT reach this # function: it goes through clusterLassoCore(), which never calls cssLasso(). if(n_interior <= 0 | hi <= lo){ return(unique(c(keep, lo))) } # Geometrically spaced filler between the two anchors, with the anchors # themselves dropped back off... mid <- exp(seq(log(hi), log(lo), length.out=n_interior + 2L)) mid <- mid[-c(1L, length(mid))] # ...and then any filler point that floating-point rounding placed on top of # an anchor removed. This filter is load-bearing rather than belt-and- # braces: without it the returned grid can repeat an anchor, which is # visible only on a path whose entries are a few ULPs apart. mid <- mid[mid < hi & mid > lo] # lo is re-appended rather than simply left at the end of a longer prefix, # and this is the load-bearing line. glmnet:::lambda.interp(), which # predict.glmnet() always calls, normalises by lambda[1] - lambda[k]. # # READ THIS BEFORE DELETING THE ANCHOR ON ALGEBRAIC GROUNDS. That normaliser # CANCELS in exact arithmetic: work the two ratios through and the weight is # just (lambda_right - s)/(lambda_right - lambda_left), with no dependence on # the grid's last element at all. So a maintainer who reasons this through # symbolically will correctly conclude the anchor is unnecessary -- and be # wrong, because in floating point the cancellation is inexact. Measured over # 1000 s values on two grids sharing every element but the last: the weight # differed in 74% of them, by up to 6 ULP, with left and right identical. # The anchor exists to reproduce the ROUNDING, not the algebra. Handing over # the same first and last elements the exact refit would have handed over is # what makes the interpolated coefficients agree bit for bit. # # This construction was validated over a six-figure sweep of designs, alphas # and s placements; the evidence is in PR #200, which is where to look # rather than at any local planning directory. Do not "simplify" it without # re-running that evidence. # The block that enforces it is test_that("anchoredLambdaGrid holds its # invariants (#125)"), NOT test_that("cssLasso is byte-identical to the # exact refit (#125)"): every natural simplification of this construction -- # dropping this re-appended anchor, keeping the prefix through kt rather than # kt + 1, and dropping the filter above -- leaves that identity pin entirely # green. return(c(keep, sort(unique(mid), decreasing=TRUE), lo)) } snapLambdaToGrid() recovers the penalty glmnet() actually fitted from the penalty cssLasso() asked for, so that predict.glmnet() reads a solved lasso path column instead of blending two adjacent ones (#199): #' Recover the fitted penalty a requested one round-tripped into #' #' Returns the element of `lambda_fitted` within `n_ulp` units in the last place #' of `s` when there is one, and `s` itself otherwise. `cssLasso()` predicts at #' the returned value rather than at `s`, which is what makes #' `predict.glmnet()` hand back a solved lasso path column, exact zeros #' included, instead of a blend of two adjacent columns. The comments in the #' body say why a tolerance this small is enough, why its two ends are bounded #' by different mechanisms, and what the function deliberately does not check. #' #' @param lambda_fitted A numeric vector of penalties (in practice the #' `$lambda` component of a fitted `glmnet` object). It may contain `NaN`, and #' it may be empty or entirely `NaN`; the last two return `s` unchanged. #' @param s The target penalty; a single nonnegative number. #' @param n_ulp The tolerance, in units in the last place of `s`: an entry of #' `lambda_fitted` matches `s` when it is within #' `n_ulp * .Machine$double.eps * s` of it. The scaling by `s` is part of the #' contract rather than an implementation detail, because the error being #' tolerated is relative. #' @return A single number: the matching element of `lambda_fitted` if there is #' one, and otherwise `s`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd snapLambdaToGrid <- function(lambda_fitted, s, n_ulp=4L){ # The one thing this function does check, and it is about s rather than # lambda_fitted, so it does not touch the no-validation decision recorded # below. WHAT IT ACTUALLY BUYS, measured rather than reasoned, because an # earlier revision of this comment claimed the wrong crossing: the sibling # anchoredLambdaGrid(lambda_path, s, n_interior) has the same arity and the # same second formal and sits in the chunk above, so a crossed call is easy # to write. Handing THIS function the anchored site's arguments passes a # scalar s, so this line never fires on that crossing, which is caught by the # two #199 red-green assertions rather than by this. (Do not restate that as # "the suite output is byte-identical with and without this line": since the # invariants block gained an expect_error() for this guard, deleting the # guard moves the suite whatever else is wrong.) What this line converts is # the TRANSPOSED call, where s is the fitted path. Without it the error comes # from the && in the tolerance test below -- which.min() itself is untroubled # and returns an index -- and reads as a coercion complaint about a length # nothing in this file explains. With it the failure names the precondition # and the line that holds it. No # legitimate caller can reach it -- checkCssLassoInputs() rejects any lambda # whose length is not 1 or 2, and the length-2 form is unpacked before the # call site -- so it is a tripwire, not a runtime check. stopifnot(length(s) == 1L) # WHY A TOLERANCE OF A FEW ULP IS THE RIGHT SIZE, and why that is a claim # about IEEE-754 rather than about this machine. glmnet() passes a supplied # penalty grid through as ulam = as.double(rev(sort(lambda))) and reports # $lambda back divided by the response scale and multiplied by it again. # That is two correctly-rounded scalar operations -- no matrix arithmetic, # so no BLAS -- and it is the whole reason a supplied penalty need not come # back verbatim. Predicting at the returned entry rather than at s is what # makes glmnet:::lambda.interp() report left == right with frac == 1, so # predict.glmnet() returns beta[, left] * 1 + beta[, right] * 0 -- the # solved column, exact zeros included -- instead of a blend that leaks the # neighbouring column's coefficients in at the scale of 1 - frac. Those # leaked coefficients are around 1e-17 and are SELECTED, because # glmnet:::nonzeroCoef()'s membership test is abs(x) > 0 with no tolerance # (#199). # # THE INSENSITIVITY OF n_ulp IS ONE-SIDED, and each end is bounded by a # different mechanism. Downwards it is not insensitive at all: measured, the # suite reddens at n_ulp = 2 and the invariants fixtures stop snapping at 1, # so the value is pinned from below and 4 carries a factor of two over the # nearest failing one. Upwards, on cssLasso()'s ordinary route, # anchoredLambdaGrid() has already placed s in the grid handed to glmnet(), # so which.min() below picks s's own echo and no n_ulp, however large, # reaches past it; only on a route where s is absent from the fitted path # does the spacing of that path become the operative bound -- and on # glmnet's default grids that spacing is of order 1e14 ulp, so it is not a # bound n_ulp can approach. # # NOTHING HERE VALIDATES lambda_fitted, and that is a decision rather than # an omission -- the same one anchoredLambdaGrid()'s roxygen states for its # own requirement on the caller. What is MEASURED, and nothing wider than # that, because two earlier revisions of this comment stated a rule and were # wrong both times: all(lambda_fitted > 0) reddens the suite, and # all(is.finite(lambda_fitted)) reddens it too, because the fixtures # deliberately drive a zero-bearing grid and a NaN-bearing one through this # function. A type check does NOT -- stopifnot(is.numeric(lambda_fitted)) # leaves the suite byte-identically green -- so this is not a rule about # validation in general and must not be written as one. The reason # it matters beyond bookkeeping is the degenerate lasso path: a validating # helper would turn that case from an empty selection into an error, on # exactly the shape issue #157 was filed to stop crashing, which is what # test_that("cssLasso survives a degenerate lasso path (#125)") exists to # hold. (Two earlier revisions of this comment enumerated which check # reddens which block and were wrong both times; the positive form above is # the correction.) # The length(j) == 1L clause below is control flow and not validation: an # all-NaN or empty lambda_fitted makes which.min() return integer(0), and # if(logical(0)) aborts, so the clause turns that case into "return s". # # THE INVARIANT cssLasso()'S NEW READ ASSUMES, named here rather than # asserted, for the reason just given. cssLasso() asserts the class of its # FIRST fit and nothing about its second, and until #199 the second fit's # $lambda was consumed only by predict.glmnet(), which owns its own # contract. What is now silently assumed of it is that it is a numeric # vector with at least one non-NaN entry, on the same scale as lambda. # # THE FIRST FORMAL IS lambda_fitted AND NOT lambda_path DELIBERATELY. The # sibling anchoredLambdaGrid(lambda_path, s, n_interior) has the same arity, # the same second formal and the chunk immediately above, so a CROSSED call # -- this function given the anchored site's arguments, both in their usual # order -- type-checks and runs, and would predict at a penalty chosen from # the wrong fit's path. (The TRANSPOSED call, arguments swapped, errors on # the scalar guard above; and neither is the route to #190's per-s-slot # union, which comes from calling predict.glmnet() with no s at all.) The # differing name is the one # signal at a call site that these take different things: the FIRST fit's # path going in, the SECOND fit's returned penalties coming back. # # The block that enforces this arithmetic is # test_that("snapLambdaToGrid holds its invariants (#199)"); the block that # enforces the call site in cssLasso() is # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). j <- which.min(abs(lambda_fitted - s)) if(length(j) == 1L && abs(lambda_fitted[j] - s) <= n_ulp*.Machine$double.eps*s){ return(lambda_fitted[j]) } return(s) } discreteYAbortProb() powers the up-front css() diagnostic for a highly discrete response (issue #131). For the default cssLasso, it estimates the probability that at least one random size-floor(n/2) subsample of y contains only a single unique value (which aborts the run in checkCssLassoInputs()). Per subsample this probability is hypergeometric; the crucial property is that it is nonzero only when some value’s count is at least floor(n/2) (a near-majority), so a balanced binary y does not trip it while a strongly majority-dominated y does: #' Estimated probability the default cssLasso aborts on a constant-y subsample #' #' For the default `cssLasso`, `css()` draws `n_sub` random subsamples of the #' selection set, each a size-`floor(n/2)` draw without replacement from the #' `n = length(y)` responses; `cssLasso` aborts on any subsample whose `y` has a #' single unique value (see `checkCssLassoInputs()`). This returns the estimated #' probability that at least one of those subsamples is all-constant. Per #' subsample, P(all one value) is hypergeometric, `sum_v C(count_v, m) / C(n, m)` #' with `m = floor(n/2)` (a term is 0 unless some value's count is at least `m`, #' i.e. that value is a near-majority), computed in log space (`lchoose`) to #' avoid overflow for large `n`. That per-subsample probability is aggregated #' over the `n_sub` subsamples treating them as independent (a close #' approximation; the small SS within-pair dependence is negligible near the #' threshold). #' #' @param y A numeric or integer response vector (the selection-set response). #' @param B Integer; the number of subsamples (`2*B` are drawn when #' `sampling_type = "SS"`). #' @param sampling_type A character string; "SS" (the reachable default) draws #' `2*B` subsamples, anything else draws `B`. #' @return A single number in `[0, 1]`: the estimated probability that at least #' one size-`floor(n/2)` subsample of `y` is all-constant (and so aborts the #' default `cssLasso`). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd discreteYAbortProb <- function(y, B, sampling_type){ n <- length(y) m <- floor(n / 2) n_sub <- if(sampling_type == "SS") 2L * B else as.integer(B) counts <- as.integer(table(y)) p_const <- sum(exp(lchoose(counts, m) - lchoose(n, m))) # sum_v C(count_v,m)/C(n,m) p_const <- min(max(p_const, 0), 1) # guard fp drift to [0,1] 1 - (1 - p_const)^n_sub } checkGetClusterSelMatrixInput(): #' Helper function to check inputs to getClusterSelMatrix function #' #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of formatClusters. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). #' @param res A binary integer matrix. `res[i, j]` = 1 if feature j was selected #' on subsample i and equals 0 otherwise, as in the output of getSelMatrix. #' (That is, each row is a selected set.) #' @return No return value; called for the side effect of erroring if the inputs #' to getClusterSelMatrix are invalid. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetClusterSelMatrixInput <- function(clusters, res){ stopifnot(is.matrix(res)) stopifnot(all(res %in% c(0, 1))) p <- ncol(res) stopifnot(nrow(res) > 0) checkClusters(clusters, p) } "],["sel-and-pred.html", "4 Selection and prediction functions", " 4 Selection and prediction functions Now that css() has been defined, we write functions to work with the output of css(). The output of these functions will be of more direct interest for most end users than the output of css(). These functions are defined separately from css() because the most computationally intensive steps happen within css(). css() can be called only once on a data set, and then the functions that follow can be explored relatively quickly (one can try different parameters, etc.). getCssSelections() takes in the results of css() along with user-defined parameters on how to select clusters (a minimum or maximum number of clusters to select, along with a cutoff for cluster selection proportions) and selects clusters as well as features from those clusters. getCssDesign() takes in the same inputs as getCssSelections() along with an unlabeled test matrix of features X (containing the same features as the X matrix provided originally to css()). It uses the results from css() to select clusters like getCssSelections(), then it uses a user-selected weighting scheme to compute weighted averages of the cluster members. It returns a test matrix of cluster representatives, which can be used for downstream predictive tasks. Finally, getCssPreds() has the same inputs as getCssDesign(), except it also accepts a set of labeled training data (where the response must be real-valued). getCssPreds() selects clusters, forms matrices of cluster representatives on the training and test data, uses the training matrix of cluster representatives (along with the vector of responses for the training data) to estimate a linear model via ordinary least squares, and finally generates predictions on the test data using this linear model. As in the previous section, we first define each function and then define the helper functions called by that function. As before, the tests for these functions are collected in the Tests chapters at the end of this document (the Tests part). getCssSelections() Calls checkCutoff(), which checks that the specified cutoff input is as expected checkWeighting() verifies the weighting input to getCssSelections() checkMinNumClusts() confirms that the min_num_clusts parameter provided to getCssSelections() is as expected Likewise for checkMaxNumClusts() getSelectedClusters() is the workhorse function of getCssSelections(), doing most of the work to get the selected clusters (and the selected features from those clusters) with the verified inputs checkSelectedClusters() checks internally that the selected clusters are as expected getAllClustWeights() gets the weights for each of the members of the selected clusters getClustWeights() gets the weights for a single cluster checkGetSelectedClustersOutput() verifies the output of getSelectedClusters() getCssDesign() checkNewXProvided() confirms that the design matrix provided to getCssDesign() matches the characteristics of the matrix that was provided to css(). checkXInputResults() also verifies these inputs (and is also used by getCssPreds() on both the training and test data) formCssDesign() is the workhorse function, generating a matrix of cluster representatives with the verified inputs to getCssDesign() checkFormCssDesignInputs() verifies the inputs to formCssDesign() (somewhat redundantly here, but formCssDesign() is called by more than one function, so this verifies the inputs to formCssDesign() regardless of where it is called). getCssPreds() checkGetCssPredsInputs() verifies the inputs to getCssPreds() getCssSelections(): #' Obtain a selected set of clusters and features #' #' Generate sets of selected clusters and features from cluster stability #' selection. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. #' (Exception: if no member of a selected cluster was selected on any subsample, #' the weights fall back to a simple average, so all of that cluster's members #' are returned.) For "simple_avg", each cluster #' member gets equal weight regardless of the individual feature selection #' proportions (that is, all cluster members within each selected cluster will #' be returned.). See Faletto and Bien (2022) for details. Default is "sparse". #' @param cutoff Numeric; getCssSelections will select and return only of those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are selected, or #' max_num_clusts are selected, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow #' a pure cutoff-based (threshold) selection that returns an empty set when no #' cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A named list with three items. \\item{selected_clusts}{A named list of #' integer vectors; each vector contains the indices of the features in one of #' the selected clusters.} \\item{selected_feats}{A named integer vector; the #' indices of the features with nonzero weights from all of the selected #' clusters.} \\item{weights}{A named list of the same length as selected_clusts. #' Each list element `weights[[j]]` is a numeric vector of the weights to use for #' the jth selected cluster, and it has the same name as the cluster it #' corresponds to.} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' getCssSelections(res) #' @export getCssSelections <- function(css_results, weighting="sparse", cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) checkCutoff(cutoff) checkWeighting(weighting) p <- ncol(css_results$feat_sel_mat) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) sel_results <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts) # sel_results$selected_clusts is guaranteed to have length at least 1 by # getSelectedClusters sel_clust_names <- names(sel_results$selected_clusts) stopifnot(length(sel_clust_names) >= 0) stopifnot(all(sel_clust_names %in% names(css_results$clusters))) sel_clusts <- list() for(i in seq_along(sel_clust_names)){ sel_clusts[[i]] <- css_results$clusters[[sel_clust_names[i]]] names(sel_clusts)[i] <- sel_clust_names[i] } stopifnot(is.list(sel_clusts)) stopifnot(length(sel_clusts) == length(sel_clust_names)) # sel_results$selected_feats is guaranteed to have length at least as long # as sel_results$selected_clusts by getSelectedClusters return(list(selected_clusts=sel_clusts, selected_feats=sel_results$selected_feats, weights=sel_results$weights)) } checkCutoff(): #' Helper function to confirm that the argument cutoff to several functions is #' as expected #' #' @param cutoff Numeric; only those clusters with selection proportions equal #' to at least cutoff will be selected by cluster stability selection. Must be #' between 0 and 1. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkCutoff <- function(cutoff){ stopifnot(is.numeric(cutoff) | is.integer(cutoff)) stopifnot(length(cutoff) == 1) stopifnot(!is.na(cutoff)) stopifnot(cutoff >= 0) stopifnot(cutoff <= 1) } checkWeighting(): #' Helper function to confirm that the argument weighting to several #' functions is as expected #' #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkWeighting <- function(weighting){ stopifnot(length(weighting)==1) stopifnot(!is.na(weighting)) if(!is.character(weighting)){ stop("Weighting must be a character") } if(!(weighting %in% c("sparse", "simple_avg", "weighted_avg"))){ stop("Weighting must be a character and one of sparse, simple_avg, or weighted_avg") } } checkMinNumClusts(): #' Helper function to confirm that the argument min_num_clusts to several #' functions is as expected #' #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param p The number of features; since this is an upper bound on the number #' of clusters of features, it is also an upper bound on min_num_clusts. #' @param n_clusters The number of clusters; note that this is an upper bound #' on min_num_clusts #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkMinNumClusts <- function(min_num_clusts, p, n_clusters){ stopifnot(length(min_num_clusts) == 1) stopifnot(is.numeric(min_num_clusts) | is.integer(min_num_clusts)) stopifnot(!is.na(min_num_clusts)) stopifnot(min_num_clusts == round(min_num_clusts)) stopifnot(min_num_clusts >= 0) stopifnot(min_num_clusts <= p) stopifnot(min_num_clusts <= n_clusters) } checkMaxNumClusts(): #' Helper function to confirm that the argument max_num_clusts to several #' functions is as expected #' #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Can be NA, in which case #' max_num_clusts will be ignored. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) max_num_clusts must be at least as #' large as min_num_clusts. #' @param p The number of features; since this is an upper bound on the number #' of clusters of features, it is also an upper bound on max_num_clusts. #' @param n_clusters The number of clusters; note that this is an upper bound #' on max_num_clusts #' @return The provided max_num_clusts, coerced to an integer if needed, and #' coerced to be less than or equal to the total number of clusters. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkMaxNumClusts <- function(max_num_clusts, min_num_clusts, p, n_clusters){ stopifnot(length(max_num_clusts) == 1) if(!is.na(max_num_clusts)){ stopifnot(is.numeric(max_num_clusts) | is.integer(max_num_clusts)) stopifnot(max_num_clusts == round(max_num_clusts)) stopifnot(max_num_clusts >= 1) stopifnot(max_num_clusts <= p) max_num_clusts <- as.integer(min(n_clusters, max_num_clusts)) stopifnot(max_num_clusts >= min_num_clusts) } return(max_num_clusts) } getSelectedClusters(): #' From css output, obtain names of selected clusters and selection proportions, #' indices of all selected features, and weights of individual cluster members #' #' If cutoff is too high for at least min_num_clusts clusters to be selected, #' then it will be lowered until min_num_clusts can be selected. After that, if #' the cutoff is too low such that more than max_num_clusts are selected, then #' the cutoff will be increased until no more than max_num_clusts are selected. #' Note that because clusters can have tied selection proportions, it is #' possible that the number of selected clusters will be strictly lower than #' max_num_clusts or strictly greater than min_num_clusts. In fact, it is #' possible that both cutoffs won't be able to be satisfied simulteaneously, #' even if there is a strictly positive difference between max_num_clusts and #' min_num_clusts. If this occurs, max_num_clusts will take precedence over #' min_num_clusts. getSelectedClusters will throw an error if the provided #' inputs don't allow it to select any clusters. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. #' (Exception: if no member of a selected cluster was selected on any subsample, #' the weights fall back to a simple average, so all of that cluster's members #' are returned.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @param cutoff Numeric; getCssSelections will select and return only of those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored. #' @return A named list with the following elements: \\item{selected_clusts}{A #' named numeric vector containing the selection proportions for the selected #' clusters. The name of each entry is the name of the corresponding cluster.} #' \\item{selected_feats}{A named integer vector; the indices of the features #' with nonzero weights from all of the selected clusters.} \\item{weights}{A #' named list of the same length as the number of selected clusters. Each list #' element `weights[[j]]` is a numeric vector of the weights to use for the jth #' selected cluster, and it has the same name as the cluster it corresponds #' to.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectedClusters <- function(css_results, weighting, cutoff, min_num_clusts, max_num_clusts){ # Check input stopifnot(inherits(css_results, "cssr")) # Eliminate clusters with selection proportions below cutoff clus_sel_props <- colMeans(css_results$clus_sel_mat) B <- nrow(css_results$feat_sel_mat) # Selection proportions are exact multiples of 1/B; work in integer count # space so the documented ">= cutoff" holds exactly (no float snapping) and # the loop thresholds step by whole counts (retires the #42 class). (#159a) counts <- round(clus_sel_props * B) thresh <- ceiling(cutoff * B - 1e-9) # Get selected clusters selected_clusts <- clus_sel_props[counts >= thresh] # Check that selected_clusts has length at least min_num_clusts while(length(selected_clusts) < min_num_clusts){ # Guard against an unbounded decrement if min_num_clusts exceeds the # number of clusters: once every cluster is selected we can't select # more, so stop (mirrors the max-loop's break) (#69). Unreachable via the # public API (checkMinNumClusts enforces min_num_clusts <= n_clusters), # but a defensive break for any internal caller. if(length(selected_clusts) == length(clus_sel_props)){ break } thresh <- thresh - 1L selected_clusts <- clus_sel_props[counts >= thresh] } # Check that selected_clusts has length at most max_num_clusts if(!is.na(max_num_clusts)){ while(length(selected_clusts) > max_num_clusts){ thresh <- thresh + 1L # Once the threshold exceeds B no count can meet it, so stop before # emptying the selection (retires the #42 float-accumulation break). if(thresh > B){ break } # Make sure we don't reduce to a selected set of size 0 if(any(counts >= thresh)){ selected_clusts <- clus_sel_props[counts >= thresh] } else{ break } } } stopifnot(length(selected_clusts) >= 0) clust_names <- names(selected_clusts) n_sel_clusts <- length(selected_clusts) # Check that n_sel_clusts is as expected, and throw warnings or an error if # not checkSelectedClusters(n_sel_clusts, min_num_clusts, max_num_clusts, max(clus_sel_props)) ### Get selected features from selected clusters clusters <- css_results$clusters stopifnot(all(clust_names %in% names(clusters))) # Get a list of weights for all of the selected clusters weights <- getAllClustWeights(css_results, selected_clusts, weighting) # Get selected features from each cluster (those features with nonzero # weights) selected_feats <- integer() for(i in seq_len(n_sel_clusts)){ clus_i_name <- clust_names[i] clust_i <- clusters[[clus_i_name]] weights_i <- weights[[i]] selected_feats <- c(selected_feats, clust_i[weights_i != 0]) } feat_names <- colnames(css_results$feat_sel_mat) names(selected_feats) <- feat_names[selected_feats] # Check output (already checked weights wihin getAllClustWeights) checkGetSelectedClustersOutput(selected_clusts, selected_feats, weights, n_clusters=length(clusters), p=ncol(css_results$feat_sel_mat)) return(list(selected_clusts=selected_clusts, selected_feats=selected_feats, weights=weights)) } checkSelectedClusters(): #' Helper function to check operations within getSelectedClusters function #' #' @param n_sel_clusts The number of selected clusters; should be constrained #' by min_num_clusts and max_num_clusts (though it may not be possible to #' satisfy both constraints simulteneously, in which case a warning will be #' thrown). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored. #' @param max_sel_prop Numeric; the maximum selection proportion observed for #' any cluster. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkSelectedClusters <- function(n_sel_clusts, min_num_clusts, max_num_clusts, max_sel_prop){ if(n_sel_clusts == 0 && min_num_clusts >= 1){ err <- paste("No clusters selected with this cutoff (try a cutoff below the maximum cluster selection proportion, ", max_sel_prop, ")", sep="") stop(err) } stopifnot(n_sel_clusts >= 0) # It may be impossible to get at least min_num_clusts or at most # max_num_clusts; if so, give a warning if(n_sel_clusts < min_num_clusts){ warn <- paste("Returning fewer than min_num_clusts = ", min_num_clusts, " clusters because decreasing the cutoff any further would require returning more than max_num_clusts = ", max_num_clusts, " clusters", sep="") warning(warn) } if(!is.na(max_num_clusts)){ if(n_sel_clusts > max_num_clusts){ warn <- paste("Returning more than max_num_clusts = ", max_num_clusts, " clusters because increasing the cutoff any further would require returning 0 clusters", sep="") warning(warn) } } } getAllClustWeights(): #' Calculate weights for each cluster member of all of the selected clusters. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param sel_clusters A named numeric vector containing the selection #' proportions for the selected clusters. The name of each entry is the name #' of the corresponding cluster. #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. #' (Exception: if no member of a selected cluster was selected on any subsample, #' the weights fall back to a simple average, so all of that cluster's members #' are returned.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @return A named list of the same length as sel_clusters of numeric vectors. #' `weights[[j]]` is the weights to use for the jth selected cluster, and it has #' the same name as the cluster it corresponds to. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getAllClustWeights <- function(css_results, sel_clusters, weighting){ # Check inputs stopifnot(inherits(css_results, "cssr")) stopifnot(is.numeric(sel_clusters)) p_ret <- length(sel_clusters) stopifnot(length(unique(names(sel_clusters))) == p_ret) stopifnot(p_ret >= 0) checkWeighting(weighting) # Get selection proportions and clusters feat_sel_props <- colMeans(css_results$feat_sel_mat) p <- length(feat_sel_props) stopifnot(p >= p_ret) clusters <- css_results$clusters stopifnot(all(names(sel_clusters) %in% names(clusters))) # Identify weights weights <- list() for(j in seq_len(p_ret)){ # Find the members of the cluster feature j is a member of cluster_j <- clusters[[names(sel_clusters)[j]]] # Get the weights for this cluster and add them to the list weights[[j]] <- getClustWeights(cluster_j, weighting, feat_sel_props) } # Add names to weights names(weights) <- names(sel_clusters) # Check output stopifnot(length(weights) == p_ret) stopifnot(is.list(weights)) for(i in seq_len(p_ret)){ stopifnot(length(clusters[[names(sel_clusters)[i]]]) == length(weights[[i]])) stopifnot(all(weights[[i]] >= 0)) stopifnot(all(weights[[i]] <= 1)) stopifnot(abs(sum(weights[[i]]) - 1) < 10^(-6)) } return(weights) } getClustWeights(): #' Calculate weights for members of a cluster using selection proportions #' #' Given a cluster of features, the selection proportions for each cluster #' member, and a specified weighting scheme, calculate the appropriate weights #' for the cluster. #' @param cluster_i An integer vector containing the indices of the members #' of a cluster. #' @param weighting Character; determines how to calculate the weights for #' individual features within the selected clusters. Only those features with #' nonzero weight within the selected clusters will be returned. Must be one of #' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is #' put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", only the features within a selected cluster that were #' themselves selected on at least one subsample will have nonzero weight. #' (Exception: if no member of a selected cluster was selected on any subsample, #' the weights fall back to a simple average, so all of that cluster's members #' are returned.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, all cluster members within #' each selected cluster will be returned.). See Faletto and Bien (2022) for #' details. #' @param feat_sel_props A numeric vector of selection proportions corresponding #' to each of the p features. #' @return A numeric vector of the same length as cluster_i containing the #' weights corresponding to each of the features in cluster_i. The weights #' will all be nonnegative and sum to 1. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getClustWeights <- function(cluster_i, weighting, feat_sel_props){ stopifnot(is.integer(cluster_i) | is.numeric(cluster_i)) stopifnot(all(cluster_i == round(cluster_i))) n_weights <- length(cluster_i) stopifnot(length(unique(cluster_i)) == n_weights) p <- length(feat_sel_props) stopifnot(all(cluster_i %in% 1:p)) # Get the selection proportions of each cluster member sel_props <- feat_sel_props[cluster_i] stopifnot(all(sel_props >= 0)) stopifnot(all(sel_props <= 1)) weights_i <- rep(as.numeric(NA), n_weights) # Weighted or simple average? if(weighting == "sparse"){ # Sparse cluster stability selection: All features in cluster with # selection proportion equal to the max # for the cluster get equal weight; rest of cluster gets 0 weight if(sum(sel_props) == 0){ weights_i <- rep(1/n_weights, n_weights) } else{ maxes <- sel_props==max(sel_props) stopifnot(sum(maxes) > 0) stopifnot(sum(maxes) <= n_weights) weights_i <- rep(0, n_weights) weights_i[maxes] <- 1/sum(maxes) } } else if(weighting == "weighted_avg"){ # Get weights for weighted average if(sum(sel_props) == 0){ weights_i <- rep(1/n_weights, n_weights) } else{ weights_i <- sel_props/sum(sel_props) } } else if(weighting == "simple_avg"){ weights_i <- rep(1/n_weights, n_weights) } else{ stop("weighting must be one of sparse, simple_avg, or weighted_avg") } stopifnot(abs(sum(weights_i) - 1) < 10^(-6)) stopifnot(length(weights_i) == n_weights) stopifnot(length(weights_i) >= 1) stopifnot(all(weights_i >= 0)) stopifnot(all(weights_i <= 1)) return(weights_i) } checkGetSelectedClustersOutput(): #' Helper function to check that output of getSelectedClusters is as expected #' #' @param selected_clusts A named numeric vector containing the selection #' proportions for the selected clusters. The name of each entry is the name of #' the corresponding cluster. #' @param selected_feats A named integer vector; the indices of the features #' with nonzero weights from all of the selected clusters. #' @param weights A named list of the same length as the number of selected #' clusters. Each list element `weights[[j]]` is a numeric vector of the weights #' to use for the jth selected cluster, and it has the same name as the cluster #' it corresponds to. #' @param n_clusters Integer; the number of clusters in the data (upper bound #' for the length of selected_clusts) #' @param p Integer; number of features in the data (all selected_feats should #' be in 1:p) #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetSelectedClustersOutput <- function(selected_clusts, selected_feats, weights, n_clusters, p){ stopifnot(is.numeric(selected_clusts)) stopifnot(all(selected_clusts >= 0)) stopifnot(all(selected_clusts <= 1)) stopifnot(length(selected_clusts) >= 0) stopifnot(length(selected_clusts) <= n_clusters) stopifnot(length(names(selected_clusts)) == length(unique(names(selected_clusts)))) stopifnot(!is.null(names(selected_clusts))) stopifnot(all(!is.na(names(selected_clusts)) & names(selected_clusts) != "")) stopifnot(length(names(selected_clusts)) == length(selected_clusts)) stopifnot(is.integer(selected_feats)) stopifnot(length(selected_feats) == length(unique(selected_feats))) stopifnot(all(selected_feats %in% 1:p)) stopifnot(length(selected_clusts) <= length(selected_feats)) stopifnot(identical(names(weights), names(selected_clusts))) stopifnot(length(weights) == length(selected_clusts)) } getCssDesign() #' Obtain a design matrix of cluster representatives #' #' Takes a matrix of observations from the original feature space and returns #' a matrix of representatives from the selected clusters based on the results #' of cluster stability selection. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param newX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newX are labeled, the names must match the variable names provided to css. #' Must not contain missing (`NA`) values. newX may be omitted if train_inds #' were provided to css to set aside observations for model estimation. If this #' is the case, then when newX is omitted getCssDesign will return a design #' matrix of cluster representatives formed from the train_inds observations #' from the matrix X provided to css. (If no train_inds were provided to css, #' newX must be provided to getCssDesign.) Default is NA. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. #' (Exception: if no member of a selected cluster was selected on any #' subsample, the weights fall back to a simple average, so all of that #' cluster's members contribute to the representative.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssDesign will only include those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty #' selection then raises an error (no design/predictions possible). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A design matrix with either nrow(newX) (or length(train_inds), if #' train_inds was provided to css and newX was not provided to getCssDesign) #' observations and number of columns equal to the number of selected clusters, #' containing the cluster representatives for each cluster. #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' train <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' newdata <- genClusteredData(n = 10, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = train$X, y = train$y, lambda = 0.01, clusters = clusters, #' B = 10) #' X_design <- getCssDesign(res, newX = newdata$X) #' dim(X_design) #' @export getCssDesign <- function(css_results, newX=NA, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) check_results <- checkNewXProvided(newX, css_results) newX <- check_results$newX newXProvided <- check_results$newXProvided rm(check_results) # #142: checkNewXProvided returns newX with its (already css-validated) column # names stripped (via checkXInputResults). Re-attach them from css_results$X # (which they were validated to match; ncol(newX) == ncol(css_results$X) for a # provided input) so the checkXInputResults call below does not spuriously warn # on a data.frame newX. Names never enter the numeric design. if(newXProvided && !is.null(colnames(css_results$X))){ colnames(newX) <- colnames(css_results$X) } n_train <- nrow(newX) results <- checkXInputResults(newX, css_results$X) newX <- results$newx feat_names <- results$feat_names # #142: re-attach newX's (already css-validated) column names that # checkXInputResults strips, so the downstream formCssDesign(newx=newX) call # doesn't spuriously warn on a data.frame newX. Names never enter the numeric # design (formCssDesign strips + builds cluster reps positionally), so this # only silences the warning; mirrors the getCssPreds fix. if(all(!is.na(feat_names))){ colnames(newX) <- feat_names } rm(results) n <- nrow(newX) p <- ncol(newX) checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) # Take provided training design matrix and testX and turn them into # matrices of cluster representatives using information from css_results if(newXProvided){ newX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=newX) } else{ newX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts) } return(newX_clusters) } checkNewXProvided() #' Helper function to confirm that the new X matrix provided to getCssDesign or #' getCssPreds matches the characteristics of the X that was provided to css. #' #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix). Must contain #' the same features (in the same number of columns) as the X matrix provided to #' css, and if the columns of trainX are labeled, the names must match the #' variable names provided to css. trainX may be omitted if train_inds were #' provided to css to set aside observations. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @return A named list with the following elements: \\item{newX}{If trainX was #' provided, this is the provided trainX matrix, coerced from a data.frame to a #' matrix if the provided trainX was a data.frame. If trainX was not provided, #' this is a matrix made up of the training indices provided to css in the #' train_inds argument.} \\item{newXProvided}{Logical; indicates whether a valid #' trainX input was provided.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkNewXProvided <- function(trainX, css_results){ newXProvided <- FALSE # trainX's own validated column names, captured from checkXInputResults so # the caller (checkGetCssPredsInputs, #153a) can restore them independently # of testX. NA for the not-provided/train_inds branch, where names are # irrelevant. trainX_feat_names <- as.character(NA) # "Was newX provided?" -- the documented default for trainX is the scalar NA # sentinel, so treat trainX as provided UNLESS it is exactly that default # (an atomic, length-1 NA). A previous length()-based heuristic # (length(trainX) > 1) misclassified a numeric vector or a one-column # data.frame (length 1) as "not provided" and silently fell back to # train_inds. The is.atomic/length/is.na test instead routes any matrix or # data.frame to the provided branch -- including an NA-CONTAINING matrix # (length > 1, so the is.na operand is short-circuited and never collapses a # multi-element matrix to a length-1 logical), which is then rejected by # checkXInputResults' checkNoNAs rather than silently replaced by the # train_inds data (#71). if(!(is.atomic(trainX) && length(trainX) == 1 && is.na(trainX))){ # trainX was provided -- it must be a matrix or data.frame (a bare # vector is not a valid design and used to fail with a cryptic # is.matrix() stopifnot downstream). if(!(is.matrix(trainX) || is.data.frame(trainX))){ stop("newX must be a matrix or data.frame with the same columns as the X provided to css().", call. = FALSE) } newXProvided <- TRUE xres <- checkXInputResults(trainX, css_results$X) trainX <- xres$newx trainX_feat_names <- xres$feat_names rm(xres) n_train <- nrow(trainX) # A single-row newX is fine -- the design is just one row of cluster # representatives, and getCssPreds/cssPredict already accept a 1-row test # set -- so don't require more than one row here (#44). stopifnot(n_train >= 1) } else{ if(length(css_results$train_inds) == 0){ stop("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") } trainX <- css_results$X[css_results$train_inds, , drop = FALSE] } stopifnot(is.matrix(trainX)) stopifnot(is.numeric(trainX) | is.integer(trainX)) stopifnot(all(!is.na(trainX))) stopifnot(ncol(trainX) >= 2) return(list(newX=trainX, newXProvided=newXProvided, feat_names=trainX_feat_names)) } checkXInputResults() #' Helper function to confirm that inputs to several functions are as expected, #' and modify inputs if needed #' #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newX are labeled, the names must match the variable names provided to css. #' @param css_X The X matrix provided to css, as in the output of the css #' function (after having been coerced from a data.frame to a matrix by css if #' needed). #' @return A named list with the following elements. \\item{feat_names}{A #' character vector containing the column names of newx (if the provided newx #' had column names). If the provided newx did not have column names, feat_names #' will be NA.} \\item{newx}{The provided newx matrix, coerced from a data.frame #' to a matrix if the provided newx was a data.frame.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkXInputResults <- function(newx, css_X){ checkNoNAs(newx, "newx") # Check if x is a matrix; if it's a data.frame, convert to matrix. newx <- coerceDataFrameToMatrix(newx, clusters = list(), arg_name = "newx") feat_names <- as.character(NA) if(!is.null(colnames(newx))){ feat_names <- colnames(newx) } else{ # In this case, newx has no column names, so same better be true of # css_X if(!is.null(colnames(css_X))){ warning("New X provided had no variable names (column names) even though the X provided to css did.") } } stopifnot(is.matrix(newx)) n <- nrow(newx) p <- ncol(newx) stopifnot(p >= 2) if(length(feat_names) > 1){ stopifnot(length(feat_names) == p) stopifnot(!("(Intercept)" %in% feat_names)) } else{ stopifnot(is.na(feat_names)) } colnames(newx) <- character() # Confirm that newx matches css_results$X if(p != ncol(css_X)){ err <- paste("Number of columns in newx must match number of columns from matrix provided to css. Number of columns in new provided X: ", p, ". Number of columns in matrix provided to css: ", ncol(css_X), ".", sep="") stop(err) } if(length(feat_names) != 1 & all(!is.na(feat_names))){ if(!identical(feat_names, colnames(css_X))){ stop("Provided feature names for newx do not match feature names provided to css") } } return(list(feat_names=feat_names, newx=newx)) } formCssDesign(): #' Create design matrix of cluster representatives from matrix of raw features #' using results of css function #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. #' (Exception: if no member of a selected cluster was selected on any #' subsample, the weights fall back to a simple average, so all of that #' cluster's members contribute to the representative.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; css will return only those clusters with selection #' proportions equal to at least cutoff. Must be between 0 and 1. Default is 0 #' (in which case all clusters are returned in decreasing order of selection #' proportion). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newx are labeled, the names must match the variable names provided to css. #' newx may be omitted if train_inds were provided to css to set aside #' observations for model estimation. If this is the case, then when newx is #' omitted formCssDesign will return a design matrix of cluster representatives #' formed from the train_inds observations from the matrix X provided to css. #' (If no train_inds were provided to css, newX must be provided to #' formCssDesign.) Default is NA. #' @return A design matrix with the same number of rows as newx (or the #' train_inds provided to css) where the columns are the constructed cluster #' representatives. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @keywords internal #' @noRd formCssDesign <- function(css_results, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA, newx=NA, weights=NULL, validated=FALSE){ # Check inputs ret <- checkFormCssDesignInputs(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx, validated = validated) newx <- ret$newx max_num_clusts <- ret$max_num_clusts rm(ret) n <- nrow(newx) p <- ncol(newx) # Get the names of the selected clusters and the weights for the features # within each cluster, according to the provided weighting rule. These depend # only on css_results and the (weighting, cutoff, min/max_num_clusts) args, # NOT on newx, so a caller that forms several designs from one css_results # (e.g. getCssPreds, which builds a train design and a test design) can # compute them once and pass them in via `weights` to skip the repeated # getSelectedClusters() work. Byte-identical: a passed-in `weights` equals # what this call would otherwise recompute (checkMaxNumClusts is idempotent, # so the max_num_clusts re-derived by checkFormCssDesignInputs above matches # the caller's already-adjusted value). (#129) if(is.null(weights)){ weights <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts)$weights } n_sel_clusts <- length(weights) if(n_sel_clusts == 0){ stop("No clusters were selected, so a design matrix / predictions cannot be formed; lower the cutoff or set min_num_clusts >= 1.") } # Form matrix of cluster representatives of selected clusters X_clus_reps <- matrix(rep(as.numeric(NA), n*n_sel_clusts), nrow=n, ncol=n_sel_clusts) colnames(X_clus_reps) <- rep(as.character(NA), n_sel_clusts) for(i in seq_len(n_sel_clusts)){ clust_i_name <- names(weights)[i] stopifnot(length(clust_i_name) == 1) stopifnot(clust_i_name %in% names(weights)) colnames(X_clus_reps)[i] <- clust_i_name clust_i <- css_results$clusters[[clust_i_name]] stopifnot(length(clust_i) >= 1) stopifnot(all(clust_i %in% 1:p)) weights_i <- weights[[clust_i_name]] stopifnot(length(clust_i) == length(weights_i)) if(length(weights_i) > 1){ X_clus_reps[, i] <- newx[, clust_i] %*% weights_i } else{ X_clus_reps[, i] <- newx[, clust_i]*weights_i } } # Check output stopifnot(all(!is.na(X_clus_reps))) stopifnot(ncol(X_clus_reps) == n_sel_clusts) stopifnot(nrow(X_clus_reps) == n) return(X_clus_reps) } checkFormCssDesignInputs(): #' Helper function to check that the inputs to formCssDesign are as expected #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". #' @param cutoff Numeric; css will return only those clusters with selection #' proportions equal to at least cutoff. Must be between 0 and 1. #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) #' @param newx A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate the design matrix of cluster #' representatives. Must contain the same features (in the same #' number of columns) as the X matrix provided to css, and if the columns of #' newx are labeled, the names must match the variable names provided to css. #' newx may be omitted if train_inds were provided to css to set aside #' observations for model estimation. If this is the case, then when newx is #' omitted formCssDesign will return a design matrix of cluster representatives #' formed from the train_inds observations from the matrix X provided to css. #' (If no train_inds were provided to css, newX must be provided to #' formCssDesign.) #' @return A named list with the following elements: \\item{newx}{If newx was #' provided, the provided newx matrix, coerced from a data.frame to a matrix if #' needed. If newx was not provided, a matrix formed by the train_inds set #' aside in the original function call to css.} \\item{max_num_clusts}{The #' provided max_num_clusts, coerced to an integer if needed, and coerced to be #' less than or equal to the total number of clusters.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkFormCssDesignInputs <- function(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx, validated=FALSE){ stopifnot(inherits(css_results, "cssr")) if(length(newx) == 1 && is.na(newx)){ if(length(css_results$train_inds) == 0){ stop("If css was not provided with indices to set aside for model training, then newx must be provided to formCssDesign") } newx <- css_results$X[css_results$train_inds, , drop = FALSE] } else if(validated){ # newx already validated + coerced by the caller (getCssPreds via # checkGetCssPredsInputs); skip the redundant checkXInputResults that # otherwise re-emits the same name/NA warnings up to 4x/call (#153b). stopifnot(is.matrix(newx)) } else{ results <- checkXInputResults(newx, css_results$X) newx <- results$newx rm(results) } p <- ncol(newx) checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) return(list(newx=newx, max_num_clusts=max_num_clusts)) } getCssPreds() #' Fit model and generate predictions from new data #' #' Generate predictions on test data using cluster stability-selected model. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param testX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as the matrix provided to css, and #' if the columns of testX are labeled, the names must match the variable names #' provided to css. Must not contain missing (`NA`) values. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. #' (Exception: if no member of a selected cluster was selected on any #' subsample, the weights fall back to a simple average, so all of that #' cluster's members contribute to the representative.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssPreds will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty #' selection then raises an error (no design/predictions possible). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to estimate the linear model from the selected #' clusters. trainX is only necessary to provide if no train_inds were #' designated in the css function call to set aside observations for model #' estimation (though even if train_inds was provided, trainX and trainY will be #' used for model estimation if they are both provided to getCssPreds). Must #' contain the same features (in the same number of columns) as the matrix #' provided to css, and if the columns of trainX are labeled, the names must #' match the variable names provided to css. Must not contain missing (`NA`) #' values. Default is NA (in which case getCssPreds uses the observations from #' the train_inds that were provided to css to estimate a linear model). #' @param trainY The response corresponding to trainX. Must be a real-valued #' response (unlike in the general css setup) because predictions will be #' generated by an ordinary least squares model. Must have the same length as #' the number of rows of trainX. Like trainX, only needs to be provided if no #' observations were set aside for model estimation by the parameter train_inds #' in the css function call. Default is NA (in which case getCssPreds uses the #' observations from the train_inds that were provided to css). #' @return A vector of predictions corresponding to the observations from testX. #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredData(n = 60, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' # Split into selection / training / test rows. #' res <- css(X = data$X[1:20, ], y = data$y[1:20], lambda = 0.01, #' clusters = clusters, B = 10) #' preds <- getCssPreds(res, testX = data$X[51:60, ], #' trainX = data$X[21:50, ], trainY = data$y[21:50]) #' preds #' @export getCssPreds <- function(css_results, testX, weighting="weighted_avg", cutoff=0, min_num_clusts=1, max_num_clusts=NA, trainX=NA, trainY=NA){ # Check inputs check_list <- checkGetCssPredsInputs(css_results, testX, weighting, cutoff, min_num_clusts, max_num_clusts, trainX, trainY) trainXProvided <- check_list$trainXProvided trainX <- check_list$trainX testX <- check_list$testX feat_names <- check_list$feat_names max_num_clusts <- check_list$max_num_clusts rm(check_list) n_train <- nrow(trainX) n <- nrow(testX) p <- ncol(testX) # The cluster weights depend only on css_results and the (weighting, cutoff, # min/max_num_clusts) arguments -- not on the design matrix -- so compute # them ONCE here and reuse for every formCssDesign() call below (train + # test) instead of letting each call recompute the same getSelectedClusters() # (colMeans + cutoff loops + getAllClustWeights). max_num_clusts is already # checkMaxNumClusts-adjusted by checkGetCssPredsInputs, and checkMaxNumClusts # is idempotent, so these weights are byte-identical to what each # formCssDesign() would otherwise compute internally. (#129) sel_weights <- getSelectedClusters(css_results, weighting, cutoff, min_num_clusts, max_num_clusts)$weights # Take provided training design matrix and testX and turn them into # matrices of cluster representatives using information from css_results if(trainXProvided){ train_X_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=trainX, weights=sel_weights, validated=TRUE) if(!is.numeric(trainY) & !is.integer(trainY)){ stop("The provided trainY must be real-valued, because predictions will be generated by ordinary least squares regression.") } y_train <- trainY } else{ train_X_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, weights=sel_weights, validated=TRUE) y_train <- css_results$y[css_results$train_inds] if(!is.numeric(y_train) & !is.integer(y_train)){ stop("Can't generate predictions from the data that was provided to css because the provided y was not real-valued (getCssPreds generated predictions using ordinary least squares regression).") } } stopifnot(length(y_train) == nrow(train_X_clusters)) testX_clusters <- formCssDesign(css_results, weighting, cutoff, min_num_clusts, max_num_clusts, newx=testX, weights=sel_weights, validated=TRUE) stopifnot(ncol(testX_clusters) == ncol(train_X_clusters)) # Get names for clusters clust_X_names <- paste("c_fit_", 1:ncol(testX_clusters), sep="") if(!is.null(colnames(train_X_clusters))){ stopifnot(identical(colnames(train_X_clusters), colnames(testX_clusters))) clust_X_names <- colnames(train_X_clusters) } # Fit linear model on training data via OLS. lm(y ~ .) adds an intercept, so # the fit is rank-deficient unless there are strictly more training # observations than clusters (nrow >= ncol + 1); guard with <= so the # n_train == n_clusters boundary errors clearly instead of silently fitting a # rank-deficient model with NA coefficients. if(nrow(train_X_clusters) <= ncol(train_X_clusters)){ err_mess <- paste("css not provided with enough indices to fit OLS model for predictions (number of training indices: ", nrow(train_X_clusters), ", number of clusters: ", ncol(train_X_clusters), "). The OLS model includes an intercept, so it needs at least one more training observation than the number of clusters. Try reducing number of clusters by increasing cutoff, or re-run css with a larger number of training indices.", sep="") stop(err_mess) } # Response name guaranteed distinct from every cluster name (issue #150): # make.unique returns "y" when no cluster is named "y" (bit-identical to # prior behavior) and e.g. "y.1" when one is, so lm() never drops a # cluster representative via a name collision with the response. resp_name <- make.unique(c(clust_X_names, "y"))[length(clust_X_names) + 1L] df <- data.frame(y_train, train_X_clusters) colnames(df) <- c(resp_name, clust_X_names) stopifnot(!anyDuplicated(colnames(df))) model <- stats::lm(stats::as.formula(paste0("`", resp_name, "` ~ .")), data = df) # Use fitted model to generate predictions on testX. Route through # olsPredictRankSafe() so a rank-deficient OLS fit predicts from its # estimable coefficients instead of crashing under R >= 4.4's predict.lm # default (see the helper's note and issue #117). df_test <- data.frame(testX_clusters) colnames(df_test) <- clust_X_names predictions <- olsPredictRankSafe(model, df_test) names(predictions) <- NULL # Check output stopifnot(is.numeric(predictions) | is.integer(predictions)) stopifnot(length(predictions) == n) stopifnot(all(is.finite(predictions))) return(predictions) } Internal OLS-prediction helper used by getCssPreds() (issue #117): #' Predict from a possibly rank-deficient OLS fit without crashing on R >= 4.4 #' #' On R >= 4.4 `stats::predict.lm()`'s default `rankdeficient = "warnif"` runs #' `qr.Q(qr.default(t(qr.R(model$qr))))`, which aborts with "NA/NaN/Inf in #' foreign function call" when `qr.R(model$qr)` contains NaN/Inf (a rank-deficient #' fit plus a LINPACK numerical pathology seen on real high-dimensional data). #' `rankdeficient = "simple"` restores the pre-4.4 behavior: predict from the #' estimable coefficients, yielding finite predictions. That argument only exists #' on R >= 4.4, so it is added conditionally (a plain retry with the argument #' would itself error on older R with "unused argument"). The `"simple"` path #' emits the stock "rank-deficient fit" warning; muffle only that specific #' warning (its advice to use `rankdeficient = "NA"` would NA-fill non-estimable #' cases and break the finiteness contract in `getCssPreds()`) so unrelated #' warnings still surface. On full-rank fits this is bit-identical to the old #' default. #' @noRd olsPredictRankSafe <- function(model, newdata) { pred_args <- list(object = model, newdata = newdata) if (getRversion() >= "4.4.0") { pred_args$rankdeficient <- "simple" } withCallingHandlers( do.call(stats::predict.lm, pred_args), warning = function(w) { if (grepl("rank-deficient fit", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } } ) } checkGetCssPredsInputs(): #' Helper function to confirm that inputs to the function getCssPreds are as #' expected, and modify inputs if needed. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param testX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as the matrix provided to css. #' @param weighting Character; determines how to calculate the weights to #' combine features from the selected clusters into weighted averages, called #' cluster representatives. Must be one of "sparse", "weighted_avg", or #' "simple_avg". For "sparse", all the weight is put on the most frequently #' selected individual cluster member (or divided equally among all the #' cluster members that are tied for the top selection proportion if there is #' a tie). For #' "weighted_avg", the weight used for each cluster member is calculated in #' proportion to the individual selection proportions of each feature. #' (Exception: if no member of a selected cluster was selected on any #' subsample, the weights fall back to a simple average, so all of that #' cluster's members contribute to the representative.) For #' "simple_avg", each cluster member gets equal weight regardless of the #' individual feature selection proportions (that is, the cluster representative #' is just a simple average of all the cluster members). See Faletto and Bien #' (2022) for details. Default is "weighted_avg". #' @param cutoff Numeric; getCssPreds will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is 0 (in which case either all clusters are used, or max_num_clusts #' are used, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). #' @param trainX A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to estimate the linear model from the selected #' clusters. trainX is only necessary to provide if no train_inds were #' designated in the css function call to set aside observations for model #' estimation (though even if train_inds was provided, trainX and trainY will be #' used for model estimation if they are both provided to getCssPreds). Must #' contain the same features (in the same number of columns) as the matrix #' provided to css, and if the columns of trainX are labeled, the names must #' match the variable names provided to css. Must not contain missing (`NA`) #' values. Default is NA (in which case getCssPreds uses the observations from #' the train_inds that were provided to css to estimate a linear model). #' @param trainY The response corresponding to trainX. Must be a real-valued #' response (unlike in the general css setup) because predictions will be #' generated by an ordinary least squares model. Must have the same length as #' the number of rows of trainX. Like trainX, only needs to be provided if no #' observations were set aside for model estimation by the parameter train_inds #' in the css function call. Default is NA (in which case getCssPreds uses the #' observations from the train_inds that were provided to css). #' @return A named list with the following elements: \\item{trainXProvided}{ #' Logical; indicates whether a valid trainX input was provided.} \\item{trainX}{ #' The provided trainX matrix, coerced from a data.frame to a matrix if the #' provided trainX was a data.frame. (If a valid trainX was not provided, this #' output simply passes whatever was provided as trainX.)} \\item{testX}{The #' provided testX matrix, coerced from a data.frame to a matrix if the provided #' testX was a data.frame.} \\item{feat_names}{A character vector containing the #' column names of testX (if the provided testX had column names). If the #' provided testX did not have column names, feat_names will be NA.} #' \\item{max_num_clusts}{The provided max_num_clusts, coerced to an integer if #' needed, and coerced to be less than or equal to the total number of clusters #' from the output of css_results.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGetCssPredsInputs <- function(css_results, testX, weighting, cutoff, min_num_clusts, max_num_clusts, trainX, trainY){ # Check inputs stopifnot(inherits(css_results, "cssr")) check_results <- checkNewXProvided(trainX, css_results) trainX <- check_results$newX trainXProvided <- check_results$newXProvided trainX_feat_names <- check_results$feat_names rm(check_results) n_train <- nrow(trainX) # #153d: distinguish an omitted trainY (documented scalar-NA default) from a # trainY that was PROVIDED but invalid (contains NA). The former falls back # to css's train_inds; the latter must error rather than silently switch the # data the model is fit on. trainYProvided <- !(is.atomic(trainY) && length(trainY) == 1 && is.na(trainY)) if(trainXProvided){ if(trainYProvided){ stopifnot(is.numeric(trainY)) if(any(is.na(trainY))){ stop("The provided trainY contains missing (NA) values; trainY must be a complete real-valued response with one value per row of trainX.") } stopifnot(n_train == length(trainY)) } else{ if(length(css_results$train_inds) == 0){ stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions") } trainXProvided <- FALSE warning("trainX provided but no trainY provided; instead, training model using the train_inds observations provided to css to set aside for model training.") } } else{ if(length(css_results$train_inds) == 0){ stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions") } if(trainYProvided){ warning("trainY provided but no trainX provided; instead, training model using the train_inds observations provided to css to set aside for model training.") } } results <- checkXInputResults(testX, css_results$X) testX <- results$newx feat_names <- results$feat_names if(all(!is.na(feat_names))){ stopifnot(length(feat_names) == ncol(testX)) stopifnot(!("(Intercept)" %in% feat_names)) colnames(testX) <- feat_names } rm(results) n <- nrow(testX) p <- ncol(testX) stopifnot(n >= 1) stopifnot(p == ncol(trainX)) # #153a: restore trainX's OWN validated names (checkNewXProvided strips them), # from the css object, independently of testX. The old #142 code derived them # from testX, so a named trainX + unnamed testX stayed name-less and tripped a # spurious downstream "no variable names" warning about a matrix the user named. if(trainXProvided && all(!is.na(trainX_feat_names))){ colnames(trainX) <- colnames(css_results$X) } # #153c: only compare names when trainX was USER-provided. Guarding here both # revives the previously-dead "testX but not trainX" branch (the old #142 # code always re-named trainX from testX, making it unsatisfiable) and # suppresses a false "trainX but not testX" warning on the train_inds default # path (where trainX is the internally-formed, unnamed train set). if(trainXProvided){ if(!is.null(colnames(trainX)) & is.null(colnames(testX))){ warning("Column names were provided for trainX but not for testX (are you sure they both contain identical features in the same order?)") } if(is.null(colnames(trainX)) & !is.null(colnames(testX))){ warning("Column names were provided for testX but not for trainX (are you sure they both contain identical features in the same order?)") } if(!is.null(colnames(trainX)) & !is.null(colnames(testX))){ stopifnot(all(colnames(trainX) == colnames(testX))) } } checkCutoff(cutoff) checkWeighting(weighting) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) return(list(trainXProvided=trainXProvided, trainX=trainX, testX=testX, feat_names=feat_names, max_num_clusts=max_num_clusts)) } "],["other-useful.html", "5 Other useful functions 5.1 Ergonomic S3 accessors: selected() and summary.cssr()", " 5 Other useful functions The following are some other functions that are useful for specific tasks. genClusteredData() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature (the latent features themselves are also provided), as in the simulation in Example 1, Section 5.1, and Section 5.2 of Faletto and Bien (2022). genClusteredDataWeighted() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature with unequal correlations (the latent features themselves are also provided), as in the simulation Section 5.3 of Faletto and Bien (2022). genClusteredDataWeightedRandom() generates jointly Gaussian data sets that include clusters of features that are correlated with a latent feature with unequal correlations (the latent features themselves are also provided) that are determined at random. getLassoLambda() uses a data set to choose a good value of lambda for subsamples of size n/2 (as in cluster stability selection) by cross-validation. getModelSize() estimates the best size for a lasso model on a provided data set. printCssDf() converts the output of the css() function (an object of class cssr) to a data.frame that is ready to be printed. We provide end-user access to printCssDf() because this data.frame itself may be useful as an object that summarizes the output from css(). print.cssr() is the print function for objects of class cssr. genClusteredData() checkGenClusteredDataInputs() checks that the inputs to genClusteredData() are as expected. genZmuY() generates the latent Z, the weak signal and noise features in X, the latent mu, and the observed y from the specified parameters. getNoiseVar() calculates the variance of the noise to add to Z so that the proxies have the specified correlation with the latent variable Z. genClusteredDataWeighted() checkGenClusteredDataWeightedInputs() verifies the inputs to genClusteredDataWeighted(). getLassoLambda() getModelSize() printCssDf() getSelectionPrototypes() identifies the prototypes from selected clusters (the feature in each cluster that is most correlated with the response) print.cssr() genClusteredData() #' Generate randomly sampled data including noisy observations of latent #' variables #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). Data is generated in the same way as in the simulations #' from Faletto and Bien (2022). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho Integer or numeric; the correlation of the proxies in each cluster #' with the latent variable. Must be in (0, 1] (greater than 0 and at most 1). Default is 0.9. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @importFrom stats rnorm runif #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' dim(data$X) #' length(data$y) #' @export genClusteredData <- function(n, p, k_unclustered, cluster_size, n_clusters=1, sig_clusters=1, rho=0.9, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataInputs(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. First, get needed # variances of noise to add noise_var <- getNoiseVar(rho) # Generate these noise features noise_mat <- matrix(stats::rnorm(n*n_clusters*cluster_size, mean=0, sd=sqrt(noise_var)), n, n_clusters*cluster_size) # Create matrix of proxies. Each cluster's cluster_size proxies are its # latent Z column plus the matching noise columns (#58); column-expand Z to # the noise block layout in one vectorized add (replaces the per-cluster # block loop; noise_mat was already drawn above, so RNG order is unchanged). # For n_clusters == 1, genZmuY returns Z as a bare numeric vector, and # as.matrix(Z) promotes it to a one-column matrix before the column-expand. col_clust <- rep(1:n_clusters, each = cluster_size) proxy_mat <- as.matrix(Z)[, col_clust, drop = FALSE] + noise_mat return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } The three genClusteredData* validators share the bulk of their checks. To keep them from drifting apart (the source of the validation inconsistencies fixed in #13), the common checks live in three shared helpers: checkGenClusteredDataInputsPre() (the checks that precede each generator’s correlation-specific checks), checkGenClusteredDataInputsPost() (the checks that follow them), and checkGenClusteredDataInputsSnrSigma() (the checks on whichever of snr and sigma_eps_sq was supplied). The two weighted validators additionally share their rho_high / rho_low checks, in checkRhoHighLow(). Each validator calls Pre(), then its own correlation/strength checks, then Post(), then SnrSigma() – preserving each validator’s exact original check order. #' Shared leading input checks for the genClusteredData* generators #' #' The checks every genClusteredData* validator runs before its #' correlation-specific checks (sig_clusters, n_clusters, and cluster_size). #' @param sig_clusters,n_clusters,cluster_size As documented in #' `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsPre <- function(sig_clusters, n_clusters, cluster_size){ stopifnot(is.numeric(sig_clusters) | is.integer(sig_clusters)) stopifnot(sig_clusters <= n_clusters) stopifnot(sig_clusters >= 0) stopifnot(sig_clusters == round(sig_clusters)) stopifnot(is.numeric(n_clusters) | is.integer(n_clusters)) stopifnot(n_clusters == round(n_clusters)) stopifnot(n_clusters >= 1) stopifnot(is.numeric(cluster_size) | is.integer(cluster_size)) stopifnot(cluster_size == round(cluster_size)) stopifnot(cluster_size >= 2) } #' Shared trailing input checks for the genClusteredData* generators #' #' The checks every genClusteredData* validator runs after its #' correlation-specific checks: the beta coefficients, k_unclustered, the #' feature-count lower bound, and that exactly one of snr / sigma_eps_sq is #' given. (Each validator then runs its own type/range checks on whichever of #' snr / sigma_eps_sq was supplied.) #' @param p,k_unclustered,cluster_size,n_clusters,beta_latent,beta_unclustered,snr,sigma_eps_sq #' As documented in `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsPost <- function(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq){ stopifnot(beta_latent != 0) stopifnot(beta_unclustered != 0) stopifnot(is.numeric(k_unclustered) | is.integer(k_unclustered)) stopifnot(k_unclustered >= 1) stopifnot(k_unclustered == round(k_unclustered)) stopifnot(is.numeric(p) | is.integer(p)) stopifnot(p == round(p)) stopifnot(p >= n_clusters*cluster_size + k_unclustered) # Same as make_sparse_blocked_linear_model_random, but ith coefficient # of weak signal features is beta_unclustered/sqrt(i) in order to have # a definitive ranking of weak signal features. if(is.na(snr) & is.na(sigma_eps_sq)){ stop("Must specify one of snr or sigma_eps_sq") } if(!is.na(snr) & !is.na(sigma_eps_sq)){ stop("Only one of snr and sigma_eps_sq may be specified") } } #' Shared snr / sigma_eps_sq input checks for the genClusteredData* generators #' #' Validates whichever of snr / sigma_eps_sq was supplied (exactly one is non-NA #' by this point, enforced by `checkGenClusteredDataInputsPost()`): it must be #' numeric and length 1, and positive (snr) or non-negative (sigma_eps_sq). #' Previously only `genClusteredData()` ran the full type/length checks; the two #' weighted generators ran a leaner version that silently accepted a #' non-numeric snr / sigma_eps_sq (which then failed later inside `genZmuY()`). #' Sharing this helper makes the three consistent (#35). #' @param snr,sigma_eps_sq As documented in `checkGenClusteredDataInputs()`. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputsSnrSigma <- function(snr, sigma_eps_sq){ if(is.na(snr)){ stopifnot(all(!is.na(sigma_eps_sq))) stopifnot(is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq)) stopifnot(length(sigma_eps_sq) == 1) stopifnot(sigma_eps_sq >= 0) } else{ stopifnot(is.numeric(snr) | is.integer(snr)) stopifnot(length(snr) == 1) stopifnot(snr > 0) } } #' Shared correlation-argument checks for the weighted genClusteredData* #' generators #' #' Validates rho_high and rho_low for #' `checkGenClusteredDataWeightedInputs()` and #' `checkGenClusteredDataWeightedRandomInputs()`: each must be a single #' non-missing number, with 0 < rho_low <= rho_high <= 1. #' #' Two things here are contract, not style. The formals must stay named #' `rho_high` / `rho_low`, because `stopifnot()` deparses the expression as #' written here, so the FORMAL's name is what the user sees (#162). And the #' type/length/NA checks must precede every range check: `"0.9" >= 0.5` is #' TRUE, since R coerces the number to a string and compares as strings #' (`"10" >= 9` is FALSE, which is the giveaway); `!is.na()` is #' vectorized, so a length-2 argument containing NA reports the plural "are #' not all TRUE" rather than the length violation; and #' `stopifnot(numeric(0) <= 1)` does not error at all, since #' `all(logical(0))` is TRUE. The tests pin every message below, so changing #' either turns many expectations red at once -- the failure mode to guard #' against is "repairing" them to match the new messages, which ships #162's #' defect green. #' @param rho_high,rho_low As documented in #' `checkGenClusteredDataWeightedInputs()` and #' `checkGenClusteredDataWeightedRandomInputs()`. Both callers are named #' because the two describe these arguments differently -- fixed correlations #' for the strong and weak proxies in one, the endpoints of the interval each #' proxy's correlation is drawn from in the other -- and their rho_high #' defaults differ (0.9 and 1). The constraint enforced here is the same for #' both. #' @return No return value; called for the side effect of erroring on bad input. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkRhoHighLow <- function(rho_high, rho_low){ stopifnot(is.numeric(rho_high) | is.integer(rho_high)) stopifnot(length(rho_high) == 1) stopifnot(!is.na(rho_high)) stopifnot(is.numeric(rho_low) | is.integer(rho_low)) stopifnot(length(rho_low) == 1) stopifnot(!is.na(rho_low)) stopifnot(rho_high <= 1) stopifnot(rho_high > 0) stopifnot(rho_low > 0) stopifnot(rho_high >= rho_low) } checkGenClusteredDataInputs() #' Check inputs to genClusteredData #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho Integer or numeric; the correlation of the proxies in each cluster #' with the latent variable. Must be in (0, 1] (greater than 0 and at most 1). Default is 0.9. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataInputs <- function(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) # rho is a (0, 1] scalar, so it gets checkAlpha()'s block verbatim (#162): # the type/length/NA checks it previously lacked entirely, plus the upper # bound the help page has always documented. Type/length/NA must precede # the range checks. "0.8" > 0 is TRUE, because R compares character to # numeric as strings, so a character rho passed straight through; and # NA_real_ > 0 does error, but as "rho > 0 is not TRUE", blaming the bound # rather than the missingness. Without the length check a vector rho # recycled its noise variance ELEMENTWISE over the flat rnorm() draw in # genClusteredData(), alternating row by row inside every proxy column -- # so no proxy kept a requested correlation, not merely some of them. stopifnot(is.numeric(rho) | is.integer(rho)) stopifnot(length(rho) == 1) stopifnot(!is.na(rho)) stopifnot(rho > 0) stopifnot(rho <= 1) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } genZmuY() #' Generates Z, weak signal features in X, noise features in X, mu, and y #' from provided parameters #' #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{Z}{The #' latent features; either a numeric vector (if n_clusters == 1) or a numeric #' matrix (if n_clusters > 1). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} #' \\item{other_X}{A numeric matrix of n observations from a multivariate normal #' distribution generated using the specified parameters, containing the weak #' signal features and the noise features that will eventually be in X. (The #' only missing features are the proxies for the latent features Z.)} #' #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @keywords internal #' @noRd genZmuY <- function(n, p, k_unclustered, cluster_size, n_clusters, sig_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq){ # Reject n < 2 up front: n = 1 collapses orig_feat_mat[, cols] to a vector # (no drop=FALSE below), which fails downstream with a cryptic "incorrect # number of dimensions". n is not validated by the shared input checkers, so # guard it here -- the one point every generator funnels through (#70). stopifnot(is.numeric(n) | is.integer(n)) stopifnot(n == round(n)) stopifnot(n >= 2) # Generate Z, weak signal features, and noise features (total of # p - n_clusters*(cluster_size - 1)) features) p_orig_feat_mat <- p - n_clusters*(cluster_size - 1) stopifnot(p_orig_feat_mat >= k_unclustered + n_clusters) orig_feat_mat <- matrix(stats::rnorm(n*p_orig_feat_mat), n, p_orig_feat_mat) # First n_clusters features are Z. Next k_unclustered features are weak # signal features. Any remaining features are noise features. Z <- orig_feat_mat[, 1:n_clusters] other_X <- orig_feat_mat[, (n_clusters + 1):p_orig_feat_mat, drop = FALSE] # Ready to create mu and y if(sig_clusters == 0){ mu <- rep(0, n) # null latent model; weak-signal features add below } else if(n_clusters > 1){ if(sig_clusters > 1){ mu <- Z[, seq_len(sig_clusters)] %*% rep(beta_latent, sig_clusters) } else{ mu <- Z[, 1] * beta_latent } } else{ mu <- Z * beta_latent } for(j in 1:k_unclustered){ mu <- mu + beta_unclustered/sqrt(j)*other_X[, j] } mu <- as.numeric(mu) # If SNR is null, use sigma_eps_sq if(!is.na(sigma_eps_sq)){ sd <- sqrt(sigma_eps_sq) }else{ sd <- sqrt(sum(mu^2) / (n * snr)) # taking snr = ||mu||^2 /(n * sigma^2) } stopifnot(is.numeric(sd) | is.integer(sd)) stopifnot(length(sd) == 1) stopifnot(!is.na(sd)) stopifnot(sd >= 0) y <- as.numeric(mu + rnorm(n, mean=0, sd=sd)) return(list(Z=Z, mu=mu, y=y, other_X=other_X)) } No tests for genZmuY(). getNoiseVar(): #' Get variance of noise to add to Z in order to yield proxies X with desired #' correlations with Z #' #' @param rho A numeric vector of desired correlations for each proxy to have #' with Z. Note: correlations must be in (0, 1] (positive and at most 1). #' @return A vector of variances of independent Gaussian random variables to add #' to Z in order to yield proxies with the desired correlations with Z. #' @author Gregory Faletto, Jacob Bien #' @examples #' # Noise variance needed so a proxy Z + N(0, v) attains each target #' # correlation with Z (correlations must be in (0, 1] (positive and at most 1)). #' getNoiseVar(c(0.9, 0.5, 1)) #' @export getNoiseVar <- function(rho){ # Correlation between standard normal Z and X = Z + epsilon where epsilon # is normal, independent of Z, and has mean 0 and variance sig_eps_sq: # # E[Z X]/sqrt{Var(Z) Var(X)} # = (E[Z^2] + E[Z*epsilon])/sqrt{1*(1 + sig_eps_sq)} # = (1 + 0)/sqrt{1 + sig_eps_sq} # # So we have # rho = 1/sqrt{1 + sig_eps_sq} # \\iff 1 + sig_eps_sq = 1/rho^2 # \\iff sig_eps_sq = 1/rho^2 - 1 stopifnot(is.numeric(rho) | is.integer(rho)) stopifnot(all(!is.na(rho))) stopifnot(length(rho) >= 1) stopifnot(all(rho > 0)) stopifnot(all(rho <= 1)) return(1/rho^2 - 1) } finalizeGenClusteredData() is the shared tail of all three genClusteredData* generators: once each generator has built its cluster-proxy matrix (the only step where the three differ), this helper column-binds the proxies with the remaining features, coerces the latent features to a matrix, runs the common output dimension checks, and returns the standard list(X, y, Z, mu). #' Assemble and validate the output of a genClusteredData* generator #' #' Shared tail of `genClusteredData()`, `genClusteredDataWeighted()`, and #' `genClusteredDataWeightedRandom()`: column-bind the freshly generated cluster #' proxies with the remaining features, coerce the latent features to a matrix, #' run the common output dimension checks, and return the standard #' `list(X, y, Z, mu)`. #' @param proxy_mat Numeric matrix; the n by n_clusters*cluster_size block of #' generated cluster proxies. #' @param other_X Numeric matrix; the weak-signal and noise features (the #' non-proxy columns of X), as returned by `genZmuY()`. #' @param y Numeric vector; the response, as returned by `genZmuY()`. #' @param mu Numeric vector; the expected response, as returned by `genZmuY()`. #' @param Z The latent features, as returned by `genZmuY()` (a numeric vector #' when n_clusters == 1); coerced to a matrix here. #' @param n Integer or numeric; the number of observations. #' @param p Integer or numeric; the total number of features (columns of X). #' @param n_clusters Integer or numeric; the number of latent variables. #' @return A list with elements X (numeric matrix), y (numeric vector), Z #' (numeric matrix), and mu (numeric vector). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd finalizeGenClusteredData <- function(proxy_mat, other_X, y, mu, Z, n, p, n_clusters){ X <- cbind(proxy_mat, other_X) Z <- as.matrix(Z) # Check output stopifnot(length(mu) == n) stopifnot(nrow(X) == n) stopifnot(ncol(X) == p) if(any(!is.na(Z))){ stopifnot(nrow(Z) == n) stopifnot(ncol(Z) == n_clusters) } return(list(X=X, y=y, Z=Z, mu=mu)) } No tests for finalizeGenClusteredData(); it is exercised through the three genClusteredData* generators (including their characterization snapshots). genClusteredDataWeighted() #' Generate randomly sampled data including noisy observations of latent #' variables, where proxies differ in their relevance (noise level) #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). Data is generated in the same way as in the simulations #' from Section 5.3 of Faletto and Bien (2022). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_strong_cluster_vars Integer or numeric; among the cluster_size #' proxies in each cluster, the first n_strong_cluster_vars will have a high #' correlation (rho_high) with the latent variable and the next cluster_size - #' n_strong_cluster_vars will have a low correlation (rho_low) with the latent #' variable. Must satisfy `1 <= n_strong_cluster_vars < cluster_size` (each #' cluster must contain at least one strong proxy and at least one weak proxy). #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the correlation of the "strong proxies" #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 0.9. #' @param rho_low Integer or numeric; the correlation of the "weak proxies" in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredDataWeighted(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_strong_cluster_vars = 2, n_clusters = 1, snr = 3) #' dim(data$X) #' @export genClusteredDataWeighted <- function(n, p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters=1, sig_clusters=1, rho_high=0.9, rho_low=0.5, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataWeightedInputs(p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. noise_var_high <- getNoiseVar(rho_high) noise_var_low <- getNoiseVar(rho_low) # Create matrix of proxies Z <- as.matrix(Z) proxy_mat <- matrix(as.numeric(NA), n, n_clusters*cluster_size) for(i in 1:n_clusters){ for(j in 1:n_strong_cluster_vars){ proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_high)) } for(j in (n_strong_cluster_vars + 1):cluster_size){ proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_low)) } } return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } checkGenClusteredDataWeightedInputs() #' Check inputs to genClusteredDataWeighted #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_strong_cluster_vars Integer or numeric; among the cluster_size #' proxies in each cluster, n_strong_cluster_vars will have a high correlation #' (rho_high) with the latent variable and cluster_size - n_strong_cluster_vars #' will have a low correlation (rho_low) with the latent variable. Must satisfy #' `1 <= n_strong_cluster_vars < cluster_size` (each cluster must contain at #' least one strong proxy and at least one weak proxy). #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the correlation of the "strong proxies" #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 0.9. #' @param rho_low Integer or numeric; the correlation of the "weak proxies" in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataWeightedInputs <- function(p, k_unclustered, cluster_size, n_strong_cluster_vars, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) stopifnot(is.integer(n_strong_cluster_vars) | is.numeric(n_strong_cluster_vars)) stopifnot(!is.na(n_strong_cluster_vars)) stopifnot(length(n_strong_cluster_vars) == 1) stopifnot(n_strong_cluster_vars == round(n_strong_cluster_vars)) stopifnot(n_strong_cluster_vars >= 1) stopifnot(n_strong_cluster_vars < cluster_size) checkRhoHighLow(rho_high, rho_low) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } No tests for checkGenClusteredDataWeightedInputs() genClusteredDataWeightedRandom() #' Generate randomly sampled data including noisy observations of latent #' variables, where proxies differ in their relevance (noise level) #' #' Generate a data set including latent features Z, observed features X (which #' may include noisy or noiseless observations of the latent features in Z), #' an observed response y which is a linear model of features from Z and X as #' well as independent mean zero noise, and mu (the responses from y without #' the added noise). #' @param n Integer or numeric; the number of observations to generate. (The #' generated X and Z will have n rows, and the generated y and mu will have #' length n.) Must be at least 2. #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. Must be at least 1. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the maximum correlation of the proxies #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 1. #' @param rho_low Integer or numeric; the minimum correlation of the proxies in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y (non-negative; 0 gives noiseless y). Only one of snr and sigma_eps_sq #' must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @examples #' set.seed(1) #' data <- genClusteredDataWeightedRandom(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' dim(data$X) #' @export genClusteredDataWeightedRandom <- function(n, p, k_unclustered, cluster_size, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=0.5, beta_latent=1.5, beta_unclustered=1, snr=as.numeric(NA), sigma_eps_sq=as.numeric(NA)){ # Check inputs checkGenClusteredDataWeightedRandomInputs(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq) ret <- genZmuY(n=n, p=p, k_unclustered=k_unclustered, cluster_size=cluster_size, n_clusters=n_clusters, sig_clusters=sig_clusters, beta_latent=beta_latent, beta_unclustered=beta_unclustered, snr=snr, sigma_eps_sq=sigma_eps_sq) Z <- ret$Z y <- ret$y mu <- ret$mu other_X <- ret$other_X # Finally, generate clusters of proxies to complete X. # Create matrix of proxies Z <- as.matrix(Z) proxy_mat <- matrix(as.numeric(NA), n, n_clusters*cluster_size) for(i in 1:n_clusters){ for(j in 1:cluster_size){ # Choose correlation at random rho_ij <- runif(n=1, min=rho_low, max=rho_high) # Get noise variance noise_var_ij <- getNoiseVar(rho_ij) proxy_mat[, (i - 1)*cluster_size + j] <- Z[, i] + rnorm(n, mean=0, sd=sqrt(noise_var_ij)) } } return(finalizeGenClusteredData(proxy_mat, other_X, y, mu, Z, n, p, n_clusters)) } checkGenClusteredDataWeightedRandomInputs() #' Check inputs to genClusteredDataWeightedRandom #' #' @param p Integer or numeric; the number of features to generate. The #' generated X will have p columns. #' @param k_unclustered Integer or numeric; the number of features in X that #' will have nonzero coefficients in the true model for y among those features #' not generated from the n_clusters latent variables (called "weak signal" #' features in the simulations from Faletto and Bien 2022). The coefficients on #' these features will be determined by beta_unclustered. #' @param cluster_size Integer or numeric; for each of the n_clusters latent #' variables, X will contain cluster_size noisy proxies that are correlated with #' the latent variable. Must be at least 2. #' @param n_clusters Integer or numeric; the number of latent variables to #' generate, each of which will be associated with an observed cluster in X. #' Must be at least 1. Default is 1. #' @param sig_clusters Integer or numeric; the number of generated latent #' features that will have nonzero coefficients in the true model for y (all of #' them will have coefficient beta_latent). Must be less than or equal to #' n_clusters. Default is 1. #' @param rho_high Integer or numeric; the maximum correlation of the proxies #' in each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and at least as large as rho_low. Default is #' 1. #' @param rho_low Integer or numeric; the minimum correlation of the proxies in #' each cluster with the latent variable. Must be a single number in (0, 1] #' (greater than 0 and at most 1), and no larger than rho_high. Default is 0.5. #' @param beta_latent Integer or numeric; the coefficient used for all #' sig_clusters latent variables that have nonzero coefficients in the true #' model for y. Can't equal 0. Default is 1.5. #' @param beta_unclustered Integer or numeric; the maximum coefficient in the #' model for y among the k_unclustered features in X not generated from the #' latent variables. The coefficients of the features will be #' beta_unclustered/sqrt(1:k_unclustered). Can't equal 0. Default is 1. #' @param snr Integer or numeric; the signal-to-noise ratio of the response #' y. If sigma_eps_sq is not specified, the variance of the noise in y will be #' calculated using the formula sigma_eps_sq = sum(mu^2)/(n * snr). Only one of #' snr and sigma_eps_sq must be specified. Default is NA. #' @param sigma_eps_sq Integer or numeric; the variance on the noise added #' to y. Only one of snr and sigma_eps_sq must be specified. Default is NA. #' @return A list of the following elements. \\item{X}{An n x p numeric matrix of #' n observations from a p-dimensional multivariate normal distribution #' generated using the specified parameters. The first n_clusters times #' cluster_size features will be the clusters of features correlated with the #' n_clusters latent variables. The next k_unclustered features will be the #' "weak signal" features, and the remaining p - n_clusters*cluster_size - #' k_unclustered features will be the unclustered noise features.} \\item{y}{A #' length n numeric vector; the response generated from X, the latent features #' from Z, and the coefficient vector, along with additive noise.} \\item{Z}{The #' latent features, as an n by n_clusters numeric matrix (one column per #' latent variable). Note that (X, Z) is multivariate Gaussian.} #' \\item{mu}{A length `n` numeric vector; the expected response given X, Z, and #' the true coefficient vector (equal to y minus the added noise).} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd checkGenClusteredDataWeightedRandomInputs <- function(p, k_unclustered, cluster_size, n_clusters, sig_clusters, rho_high, rho_low, beta_latent, beta_unclustered, snr, sigma_eps_sq){ checkGenClusteredDataInputsPre(sig_clusters, n_clusters, cluster_size) checkRhoHighLow(rho_high, rho_low) checkGenClusteredDataInputsPost(p, k_unclustered, cluster_size, n_clusters, beta_latent, beta_unclustered, snr, sigma_eps_sq) checkGenClusteredDataInputsSnrSigma(snr, sigma_eps_sq) } No tests for checkGenClusteredDataWeightedRandomInputs() getLassoLambda(): #' Get lambda value for lasso #' #' Chooses a lambda value for the lasso used on a subsample of size n/2 (as in #' cluster stability selection) by cross-validation. #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors that will be used by cluster stability #' selection. Must not contain missing (`NA`) values. #' @param y The response; an n-dimensional numeric or integer vector. (Unlike #' in the more general css setup, this response must be real-valued since #' lambda will be determined using the lasso with cross-validation.) #' @param lambda_choice Character; either "min" or "1se". If "min", chooses #' the lambda that minimizes the cross-validated error; if "1se", chooses the #' largest lambda within one standard error of the minimum error lambda #' (resulting in a smaller selected set, which may be desirable because the #' model size corresponding to the minimum error lambda tends to be larger #' than optimal. See, for example, Bühlmann and Meinshausen 2006, Prop. 1 and #' Bühlmann and van de Geer 2011, Section 2.5.1.). Default is "1se". #' @param nfolds Numeric or integer; the number of folds for cross-validation. #' Must be at least 3 (the minimum for cv.glmnet). Default is 10. #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Default is 1 (in which case the penalty is for lasso). #' @return A numeric; the selected value of lambda. #' @author Gregory Faletto, Jacob Bien #' @references Bühlmann, P., & Meinshausen, N. (2006). High-Dimensional Graphs #' and Variable Selection With the Lasso. \\emph{The Annals of Statistics}, #' 34(3), 1436–1462. \\url{https://doi.org/10.1214/009053606000000281}. #' \\cr Peter Bühlmann and Sara van de Geer. Statistics for High-Dimensional #' Data. \\emph{Springer Series in Statistics}. Springer, Heidelberg, 2011. ISBN #' 978-3-642-20191-2. \\url{http://dx.doi.org/10.1007/978-3-642-20192-9}. \\cr #' Jerome Friedman, Trevor Hastie, Robert Tibshirani (2010). Regularization #' Paths for Generalized Linear Models via Coordinate Descent. \\emph{Journal of #' Statistical Software}, 33(1), 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' lambda <- getLassoLambda(X = data$X, y = data$y, nfolds = 5) #' lambda #' @export getLassoLambda <- function(X, y, lambda_choice="1se", nfolds=10, alpha=1){ stopifnot(is.character(lambda_choice)) stopifnot(length(lambda_choice) == 1) stopifnot(!is.na(lambda_choice)) stopifnot(lambda_choice %in% c("min", "1se")) checkNoNAs(X, "X") # Accept a data.frame like the other X-accepting exports (#51): coerce to a # matrix via the shared helper. clusters = list() makes the column-count # guard inert (getLassoLambda has no clusters argument). X <- coerceDataFrameToMatrix(X, clusters = list()) stopifnot(is.matrix(X)) stopifnot(is.numeric(X) | is.integer(X)) # Require at least two features, mirroring css()'s stopifnot(p >= 2). A 1-col # X (e.g. cssSelect()/cssPredict() called with p = 1) would otherwise reach # cv.glmnet with a single column and fail cryptically; this fires the same # clean "p >= 2 is not TRUE" message as css(). p <- ncol(X) stopifnot(p >= 2) n <- nrow(X) stopifnot(is.numeric(nfolds) | is.integer(nfolds)) stopifnot(length(nfolds) == 1) stopifnot(nfolds == round(nfolds)) stopifnot(nfolds >= 3) checkAlpha(alpha) # Since we are using the lasso, we require y to be a real-valued response # (unlike for the general cluster stability selection procedure, where y # can have a more general format as long as a suitable feature selection # function is provided by the user). checkFiniteY also rejects NA/NaN/Inf # here, BEFORE the random subsample below, so a non-finite y fails fast and # deterministically rather than only when the bad value lands in the draw. checkFiniteY(y, "y") stopifnot(n == length(y)) # Sample size to use: inflate n/2 by a factor of nfolds/(nfolds - 1), # so that each individual lasso fit is of size floor(n/2) n_sample <- min(round(n/2*nfolds/(nfolds - 1)), n) # n_sample is the number of observations actually passed to cv.glmnet. If it # is too small for even 3-fold CV, error clearly here (reporting the # requested nfolds) instead of letting cv.glmnet crash with "nfolds must be # bigger than 3". Otherwise clamp nfolds into [3, n_sample] so we never end # up below glmnet's minimum or above the available sample size. if(n_sample < 3){ stop(paste0("Sample size n = ", n, " is too small to choose lambda by ", nfolds, "-fold cross-validation; supply a larger n, a smaller nfolds, or lambda directly.")) } nfolds <- max(3L, min(nfolds, n_sample)) inds_size <- sample(1:n, n_sample) # cv.glmnet overrides grouped to FALSE, and warns that it did, whenever a # fold would hold fewer than 3 observations -- its rule is nrow(x)/nfolds < 3. # Setting grouped here to what cv.glmnet would set anyway leaves the fit # identical and spares small-n callers a warning about their sample size that # says nothing about cssr (#186). x has n_sample rows, and nfolds is the # clamped value just above. That rule is specific to the gaussian family # fixed just below -- cv.coxnet flips grouped the other way -- so a family # change would invalidate this guard. getModelSize() carries the same guard; # a change to either belongs in both. size_results <- glmnet::cv.glmnet(x=X[inds_size, ], y=y[inds_size], family="gaussian", nfolds=nfolds, alpha=alpha, grouped=n_sample/nfolds >= 3) lambda_ret <- size_results[[paste("lambda.", lambda_choice, sep="")]] # Check output stopifnot(length(lambda_ret) == 1) stopifnot(is.numeric(lambda_ret) | is.integer(lambda_ret)) stopifnot(lambda_ret >= 0) return(lambda_ret) } getModelSize(): #' Automated estimation of model size #' #' This function is uses the lasso with cross-validation to estimate the #' model size. Before using the lasso, in each cluster all features will be #' dropped from X except the one feature with the highest marginal correlation #' with y, as in the protolasso (Reid and Tibshirani 2016). #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y A length-n numeric vector containing the responses; `y[i]` is the #' response corresponding to observation `X[i, ]`. (Note that for the css #' function, y does not have to be a numeric response, but for this function, #' the underlying selection procedure is the lasso, so y must be a real-valued #' response.) #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster, as in the output of css. #' (The length of list clusters is equal to the number of clusters.) All #' identified clusters must be non-overlapping, and all features must appear in #' exactly one cluster (any unclustered features should be in their own #' "cluster" of size 1). Any identical (duplicated) clusters will be removed, #' keeping the first occurrence and its name. CAUTION: if the provided X is a #' data.frame that #' contains a categorical feature with more than two levels, then the resulting #' matrix made from model.matrix will have a different number of columns than #' the provided data.frame, some of the feature numbers will change, and the #' clusters argument will not work properly (in the current version of the #' package). To get correct results in this case, please use model.matrix to #' convert the data.frame to a numeric matrix on your own, then provide this #' matrix and cluster assignments with respect to this matrix. #' @param alpha Numeric; the elastic net mixing parameter for the #' cross-validated fit used to estimate the model size. Must be in `(0, 1]`. #' Default is 1 (in which case the penalty is the lasso). Set alpha to match #' the alpha used for feature selection so the model-size estimate is #' consistent with the elastic-net selection (see `cssSelect` / `cssPredict`). #' @return An integer; the estimated size of the model. The minimum returned #' value is 1, even if the lasso with cross-validation chose no features. #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' getModelSize(X = data$X, y = data$y, clusters = clusters) #' @export getModelSize <- function(X, y, clusters, alpha = 1){ # Validate alpha (a single number in (0, 1]). alpha is threaded into the # cv.glmnet fit below so the model-size estimate uses the same elastic-net # mixing as feature selection. checkAlpha(alpha) stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) stopifnot(is.numeric(X) | is.integer(X)) n <- nrow(X) # Since the model size will be determined by cross-validation, the provided # y must be real-valued and finite (this should be checked internally in # other functions before getModelSize is called, but this check is here just # in case). checkFiniteY(y, "y") stopifnot(length(y) == n) # Check clusters argument clusters <- checkCssClustersInput(clusters) ### Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } clusters <- formatClusters(clusters, p=ncol(X), clust_names=clust_names)$clusters X_size <- X if(length(clusters) > 0){ # Create modified design matrix by dropping all but one feature from # each cluster feats_to_drop <- integer() for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] if(length(cluster_i) > 1){ feat_to_keep <- identifyPrototype(cluster_i, X, y) feats_to_drop <- c(feats_to_drop, setdiff(cluster_i, feat_to_keep)) } } if(length(feats_to_drop) > 0){ X_size <- X_size[, -1*feats_to_drop, drop=FALSE] } } # cv.glmnet requires at least two columns; if cluster reduction leaves a # single feature, the only possible model size is 1. if(ncol(X_size) < 2){ return(1L) } # 10 is cv.glmnet's own default for nfolds; naming it keeps the fit and the # grouped guard below from ever disagreeing about the fold count. nfolds_size <- 10L # As in getLassoLambda(): cv.glmnet overrides grouped to FALSE, and warns, # when nrow(x)/nfolds < 3, for the gaussian family fixed just below (other # families differ; cv.coxnet flips grouped the other way). Setting it # explicitly is behavior-identical and keeps that nag out of small-n callers' # consoles (#186). nrow(X_size), not the already-bound n, because it is # glmnet's N = nrow(x) for the very matrix passed as x -- the two are equal # here only because cluster reduction drops columns and never rows. size_results <- glmnet::cv.glmnet(x=X_size, y=y, family="gaussian", alpha=alpha, nfolds=nfolds_size, grouped=nrow(X_size)/nfolds_size >= 3) coefs <- as.numeric(glmnet::coef.glmnet(size_results, s="lambda.1se")) # Number of nonzero coefficients (subtract one in order to ignore intercept) size <- length(coefs[coefs != 0]) - 1 # Check output stopifnot(is.numeric(size) | is.integer(size)) stopifnot(!is.na(size)) stopifnot(length(size) == 1) stopifnot(size == round(size)) return(as.integer(max(size, 1))) } buildCssDf() builds the printable cluster-summary data.frame from a css_results object and an already-obtained named vector of selected clusters. It is factored out of printCssDf() (issue #129) so that a caller which has already computed the selected clusters – notably summary.cssr(), which calls getCssSelections() itself – can reuse that result instead of triggering a second identical getCssSelections() call. It is an internal (@noRd) helper, so the exported printCssDf() keeps its exact signature and man page: #' Build the printable cluster-summary data.frame from selected clusters #' #' Constructs the data.frame returned by printCssDf() (and summary.cssr()) from #' a css_results object and an already-obtained named vector of selected #' clusters. Factored out of printCssDf() (#129) so callers that have already #' computed the selected clusters (e.g. summary.cssr(), which calls #' getCssSelections() itself) can reuse that result rather than triggering a #' second identical getCssSelections() call. Because cluster selection is #' invariant to the weighting rule, the sel_clusts computed by summary.cssr() #' for any weighting matches the "sparse"-default selection printCssDf() would #' recompute, so the returned data.frame is byte-identical either way. #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param sel_clusts A named numeric vector of selected clusters with their #' selection proportions, as returned in the selected_clusts element of #' getCssSelections() / getSelectedClusters() (the value printCssDf() itself #' obtains via getCssSelections()). May be empty (length 0), in which case a #' well-formed zero-row data.frame is returned. #' @return A data.frame; each row contains a cluster, arranged in decreasing #' order of cluster selection proportion from top to bottom (see printCssDf() #' for the full column description). #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd buildCssDf <- function(css_results, sel_clusts){ # An empty selection is valid post-#107 (e.g. cutoff = 1 with # min_num_clusts = 0 when no cluster clears the cutoff). Return a well-formed # zero-row data.frame whose columns mirror the populated branch below for the # same object: 5 columns (with ClustProtoName) when X has column names, 4 # otherwise -- names(prototypes) is non-NULL iff colnames(css_results$X) is, # since prototype names come from colnames(X). (#120) if(length(sel_clusts) == 0){ if(!is.null(colnames(css_results$X))){ return(data.frame(ClustName=character(0), ClustProtoName=character(0), ClustProtoNum=integer(0), ClustSelProp=numeric(0), ClustSize=integer(0))) } return(data.frame(ClustName=character(0), ClustProtoNum=integer(0), ClustSelProp=numeric(0), ClustSize=integer(0))) } # Get prototypes (feature from each cluster with highest selection # proportion, breaking ties by using marginal correlations of features with # y from data provided to css if y is real-valued) prototypes <- getSelectionPrototypes(css_results, sel_clusts) # Cluster selection proportions if(length(sel_clusts) > 1){ sel_clust_sel_props <- colMeans(css_results$clus_sel_mat[, names(sel_clusts)]) } else{ sel_clust_sel_props <- mean(css_results$clus_sel_mat[, names(sel_clusts)]) } # Data.frame: name of cluster, cluster prototype, selection proportion, # cluster size if(!is.null(names(prototypes))){ print_df <- data.frame(ClustName=names(sel_clusts), ClustProtoName=names(prototypes), ClustProtoNum=unname(prototypes), ClustSelProp=sel_clust_sel_props, ClustSize=lengths(sel_clusts)) } else{ print_df <- data.frame(ClustName=names(sel_clusts), ClustProtoNum=unname(prototypes), ClustSelProp=sel_clust_sel_props, ClustSize=lengths(sel_clusts)) } print_df <- print_df[order(print_df$ClustSelProp, decreasing=TRUE), ] rownames(print_df) <- NULL stopifnot(is.data.frame(print_df)) stopifnot(nrow(print_df) >= 1) return(print_df) } printCssDf(): #' Prepares a data.frame summarizing cluster stability selection output to print #' #' Print a summary of the information from the css function. #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param cutoff Numeric; the outputted data.frame will display only those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are displayed, or #' max_num_clusts are, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @return A data.frame; each row contains a cluster, arranged in decreasing #' order of cluster selection proportion from top to bottom. The columns are #' ClustName (the name of the cluster that was either provided to css or made by #' css if no name was provided); ClustProtoName (the name of the selection #' prototype from the cluster, which is the feature with the greatest individual #' selection proportion among all the cluster members, with ties broken by #' choosing the feature with the highest correlation with the response if the #' response is real-valued; only returned if the features are named), #' ClustProtoNum (the column number of the prototype in the X matrix provided to #' css), ClustSelProp (the cluster's selection proportion), and ClustSize (the #' size of the cluster). #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' printCssDf(res) #' @export printCssDf <- function(css_results, cutoff=0, min_num_clusts=1, max_num_clusts=NA){ # Check inputs stopifnot(inherits(css_results, "cssr")) checkCutoff(cutoff) p <- ncol(css_results$feat_sel_mat) checkMinNumClusts(min_num_clusts, p, length(css_results$clusters)) max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p, length(css_results$clusters)) sel_clusts <- getCssSelections(css_results, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts)$selected_clusts # printCssDf keeps its exact exported signature; the table-building work # (empty-selection handling, prototypes, selection proportions, ordering) # now lives in the internal buildCssDf() helper so summary.cssr() can reuse # an already-computed sel_clusts instead of making a second identical # getCssSelections() call. Byte-identical: buildCssDf() consumes sel_clusts # exactly as this body did. (#129) return(buildCssDf(css_results, sel_clusts)) } getSelectionPrototypes() #' Identify selection prototypes from selected clusters #' #' Takes in list of selected clusters and returns an integer vector of the #' indices of the features that were most frequently selected from each cluster #' #' @param css_results An object of class "cssr" (the output of the function #' css). #' @param selected_clusts A list of integer vectors; each vector must contain #' the indices of features in a cluster. #' @return An integer vector (of length equal to the number of clusters) of the #' indices of the feature prototypes (the features from each cluster that were #' selected the most often individually by the base method in cluster stability #' selection). In the case of a tie, the tie is broken by choosing the feature #' most correlated with the response in the full data set provided to css. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectionPrototypes <- function(css_results, selected_clusts){ # Check inputs stopifnot(inherits(css_results, "cssr")) stopifnot(is.list(selected_clusts)) n_selected_clusts <- length(selected_clusts) # An empty selection is valid post-#107: getCssSelections() can return zero # selected clusters (e.g. cutoff = 1 with min_num_clusts = 0 when no cluster # clears the cutoff). Return an empty integer vector before the non-empty # guards below; this also avoids the 1:0 foot-gun in the for loop. (#120) if(n_selected_clusts == 0){ return(integer(0)) } stopifnot(n_selected_clusts >= 1) stopifnot(all(lengths(selected_clusts) >= 1)) prototypes <- rep(as.integer(NA), n_selected_clusts) feat_sel_props <- colMeans(css_results$feat_sel_mat) for(i in 1:n_selected_clusts){ clust_i <- selected_clusts[[i]] sel_props_i <- feat_sel_props[clust_i] proto_i <- clust_i[sel_props_i == max(sel_props_i)] stopifnot(length(proto_i) >= 1) if(length(proto_i) > 1){ if(is.numeric(css_results$y) | is.integer(css_results$y)){ # Break tie by marginal correlation. suppressWarnings + NA->0 # mirrors identifyPrototype (#59): a constant column has # undefined correlation (cor() returns NA with a # "standard deviation is zero" warning) -- treat it as 0 so # it never wins the tie-break and never poisons max() (#68). corrs_i <- suppressWarnings(abs(stats::cor( css_results$X[, proto_i, drop = FALSE], css_results$y)[, 1])) corrs_i[is.na(corrs_i)] <- 0 proto_i <- proto_i[corrs_i == max(corrs_i)] } } # If there is still a tie, break by choosing the first feature of those # remaining prototypes[i] <- proto_i[1] names(prototypes)[i] <- colnames(css_results$X)[proto_i[1]] } # Check output stopifnot(is.integer(prototypes)) stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) return(prototypes) } print.cssr() #' Print cluster stability selection output #' #' Print a summary of the information from the css function (using output from #' printCssDf function). #' @param x An object of class "cssr" (the output of the function css). #' @param cutoff Numeric; print.cssr will display only those #' clusters with selection proportions equal to at least cutoff. Must be between #' 0 and 1. Default is 0 (in which case either all clusters are displayed, or #' max_num_clusts are, if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param ... Additional arguments to generic print.data.frame function #' @return Invisibly, the unchanged `cssr` object `x` (following the standard #' convention for `print` methods). Called for its side effect: printing a #' summary table with one row per cluster, arranged in decreasing order of #' cluster selection proportion from top to bottom. The printed columns are #' ClustName (the name of the cluster that was either provided to css or made by #' css if no name was provided); ClustProtoName (the name of the selection #' prototype from the cluster, which is the feature with the greatest individual #' selection proportion among all the cluster members, with ties broken by #' choosing the feature with the highest correlation with the response if the #' response is real-valued; only shown if the features are named); ClustProtoNum #' (the column number of the prototype in the X matrix provided to css); #' ClustSelProp (the cluster's selection proportion); and ClustSize (the size of #' the cluster). #' @author Gregory Faletto, Jacob Bien #' @export print.cssr <- function(x, cutoff=0, min_num_clusts=1, max_num_clusts=NA, ...){ df <- printCssDf(css_results=x, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) if(nrow(df) == 0){ # Empty selection (#120): no table to print. cat(sprintf("(no clusters selected at cutoff %s)\\n", format(cutoff))) } else{ print.data.frame(df, ...) } invisible(x) } plot.cssr() gives a base-graphics bar plot of the cluster (or feature) selection proportions, sorted in decreasing order, with the cutoff drawn as a dashed reference line (for type = \"clusters\") and the selected clusters (or features) highlighted: #' Plot cluster (or feature) selection proportions from cluster stability #' selection #' #' Produce a base-graphics bar plot of the selection proportions of a fitted #' `cssr` object: one bar per cluster (the default) or per feature, sorted in #' decreasing order of selection proportion. When `cutoff > 0` a dashed #' reference line is drawn at the cutoff (for `type = "clusters"`), and the bars #' whose cluster (or feature) is selected -- at the given `cutoff` and #' cluster-count constraints -- are highlighted in `sel_col`, the rest in #' `unsel_col`. #' #' The selection that determines the highlight is obtained from #' [getCssSelections()] with the same `cutoff`, `min_num_clusts`, #' `max_num_clusts`, and `weighting`. Which clusters are selected does not #' depend on `weighting`; which features are selected does (the weighting #' determines which members of the selected clusters have nonzero weight and are #' therefore highlighted when `type = "features"`). #' #' Note that, to match the positional argument order of [print.cssr()], the #' second positional argument is `cutoff`; `type`, `weighting`, and the #' graphical parameters must be supplied by name (for example #' `plot(x, type = "features")`). #' #' @param x An object of class "cssr" (the output of the function [css()]). #' @param cutoff Numeric; the selection-proportion threshold used both to draw #' the dashed reference line (when greater than 0) and to determine which bars #' are highlighted as selected. The dashed reference line is drawn only for #' `type = "clusters"`; for `type = "features"` no line is drawn, because the #' bars show feature proportions while highlighting follows the cluster-level #' selection. Must be between 0 and 1. Default is 0 (in which case no reference #' line is drawn and, unless `max_num_clusts` restricts it, every cluster is #' treated as selected). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' treat as selected regardless of cutoff. (If the chosen cutoff would select #' fewer than min_num_clusts clusters, the cutoff is effectively lowered until #' at least min_num_clusts clusters are selected.) Default is 1. May be set to 0 #' to allow a pure cutoff-based highlight that can be empty (no bar highlighted) #' when no cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' treat as selected regardless of cutoff. (If the chosen cutoff would select #' more than max_num_clusts clusters, the cutoff is effectively raised until at #' most max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts bars #' (or fewer than min_num_clusts) to be highlighted; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param type Character; either "clusters" (the default) to plot one bar per #' cluster, or "features" to plot one bar per feature. May be abbreviated. #' @param weighting Character; passed to [getCssSelections()] to determine which #' individual features are selected (and therefore highlighted) when #' `type = "features"`. It has no effect on the cluster bars or on which #' clusters are highlighted. Must be one of "sparse", "weighted_avg", or #' "simple_avg". Default is "sparse" (matching [getCssSelections()] and #' [selected()]). #' @param ylim Numeric vector of length 2; the y-axis limits for the bar plot. #' Default is `c(0, 1)`, the natural range of a selection proportion. #' @param sel_col The color used to fill the bars of selected clusters (or #' features). Default is "steelblue". #' @param unsel_col The color used to fill the bars of unselected clusters (or #' features). Default is "grey70". #' @param ... Additional graphical parameters passed on to #' [graphics::barplot()] (for example `main` or `cex.names`). The bar heights, #' fill colors, and `ylim` are controlled by this method; supplying `col` here, #' or the `ylim` argument, overrides the highlight colors or the default y-axis #' limits. #' @return Invisibly, the numeric vector of selection proportions that were #' plotted: the `colMeans()` of the cluster (or feature) selection matrix, #' sorted in decreasing order, named by cluster (always) or by feature (when the #' features of `X` were named; unnamed otherwise). Called primarily for its side #' effect: drawing the bar plot. #' @author Gregory Faletto, Jacob Bien #' @seealso [print.cssr()] and [summary.cssr()] for printed / tabular overviews #' of the same selection proportions; [selected()] to extract the selected #' clusters or features; [getCssSelections()] for the underlying selection used #' to highlight the bars. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' # Name the features so the feature plot shows labeled, highlighted bars #' # (genClusteredData returns X with no column names). #' X <- data$X #' colnames(X) <- paste0("V", seq_len(ncol(X))) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = X, y = data$y, lambda = 0.01, clusters = clusters, B = 10) #' # Cluster selection proportions (the default): #' plot(res) #' # Feature selection proportions, highlighting the selected features: #' plot(res, type = "features") #' @export plot.cssr <- function(x, cutoff = 0, min_num_clusts = 1, max_num_clusts = NA, type = c("clusters", "features"), weighting = "sparse", ylim = c(0, 1), sel_col = "steelblue", unsel_col = "grey70", ...){ type <- match.arg(type) sel <- getCssSelections(x, weighting = weighting, cutoff = cutoff, min_num_clusts = min_num_clusts, max_num_clusts = max_num_clusts) if(type == "clusters"){ props <- colMeans(x$clus_sel_mat) # named by cluster (guaranteed) is_sel <- names(props) %in% names(sel$selected_clusts) ylab <- "Cluster selection proportion" } else { props <- colMeans(x$feat_sel_mat) # named iff X was named is_sel <- seq_along(props) %in% as.integer(sel$selected_feats) # INDEX-based -> robust to unnamed X ylab <- "Feature selection proportion" } ord <- order(props, decreasing = TRUE) props <- props[ord]; is_sel <- is_sel[ord] labels <- names(props); if(is.null(labels)) labels <- as.character(ord) # index labels if X unnamed # Method defaults go on the DEFAULTS side of the merge so a user-supplied col # or ylim in `...` wins (matching the @param ... doc); height is forced AFTER # the merge because the bar heights ARE the selection proportions (#160a). args <- utils::modifyList( list(names.arg = labels, las = 2, ylab = ylab, col = ifelse(is_sel, sel_col, unsel_col), ylim = ylim), list(...)) args$height <- props do.call(graphics::barplot, args) if(cutoff > 0 && type == "clusters") graphics::abline(h = cutoff, lty = 2, col = "red") invisible(props) # sorted; names as-is (so it equals sort(colMeans(...)) for the test) } 5.1 Ergonomic S3 accessors: selected() and summary.cssr() The functions above (getCssSelections(), printCssDf(), print.cssr()) already expose everything an end user needs, but they take the cssr object as css_results and return heterogeneous output. For a more idiomatic R experience – mirroring the selected() and summary.stabsel() interface of the stabs package – we add a small S3 layer on top of these internals. selected() is a generic accessor that returns the selected clusters (or features) from a fitted cssr object, and summary.cssr() returns a compact, computable overview object with its own print method. Both are thin wrappers over getCssSelections()/printCssDf(); they introduce no new methodology. selected() generic: #' Extract the selected clusters or features from cluster stability selection #' #' A convenient S3 accessor for the selected clusters (the default) or the #' selected features of a fitted `cssr` object, without re-running the #' (computationally expensive) subsampling. This is a thin wrapper around #' [getCssSelections()]. #' #' Note that, unlike the `selected()` accessor in the \\pkg{stabs} package (which #' returns the selected *variables*), the default here returns the selected #' *clusters* -- the natural unit of cluster stability selection. Pass #' `type = "features"` to obtain the flat integer vector of selected features #' instead. #' #' @param object An object of class "cssr" (the output of the function [css()]). #' @param ... Additional arguments passed to methods (currently unused). #' @return For the `cssr` method: if `type = "clusters"` (the default), a named #' list of integer vectors (each the indices of the features in one selected #' cluster; an empty list if no cluster is selected); if `type = "features"`, a #' named integer vector of the indices of the selected features (an empty integer #' vector if none). #' @author Gregory Faletto, Jacob Bien #' @references <<faletto2022>> #' @seealso [summary.cssr()] for an overview (counts plus a per-cluster table); #' [getCssSelections()] for the underlying selection (clusters, features, and #' weights together); [printCssDf()] and [print.cssr()] for the printed summary. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' # Selected clusters (the default): #' selected(res) #' # Selected features (a flat integer vector): #' selected(res, type = "features") #' @export selected <- function(object, ...){ UseMethod("selected") } selected.cssr() method: #' @param type Character; either "clusters" (the default) to return the named #' list of selected clusters, or "features" to return the flat integer vector of #' selected features. May be abbreviated. #' @param cutoff Numeric; only those clusters with selection proportions equal to #' at least cutoff will be selected. Must be between 0 and 1. Default is 0 (in #' which case either all clusters are selected, or max_num_clusts are selected, #' if max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than #' min_num_clusts clusters, the cutoff will be lowered until at least #' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow #' a pure cutoff-based (threshold) selection that returns an empty result when no #' cluster's selection proportion meets the cutoff. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param weighting Character; passed to [getCssSelections()] to determine the #' weights of individual features within the selected clusters. This affects #' ONLY `type = "features"` (it determines which cluster members have nonzero #' weight and are therefore returned); it is a no-op for `type = "clusters"`, #' whose selected clusters, selection proportions, and sizes do not depend on the #' weighting. Must be one of "sparse", "weighted_avg", or "simple_avg". See #' [getCssSelections()] for details. Default is "sparse". #' @rdname selected #' @export selected.cssr <- function(object, type=c("clusters", "features"), cutoff=0, min_num_clusts=1, max_num_clusts=NA, weighting="sparse", ...){ stopifnot(inherits(object, "cssr")) type <- match.arg(type) # Thin wrapper: getCssSelections validates all inputs (checkCutoff, # checkWeighting, checkMinNumClusts, checkMaxNumClusts) and cleanly returns # empty results on an empty selection (e.g. cutoff = 1, min_num_clusts = 0). sel <- getCssSelections(object, weighting=weighting, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) if(type == "clusters"){ return(sel$selected_clusts) } return(sel$selected_feats) } summary.cssr(): #' Summarize cluster stability selection output #' #' Produce a concise, computable overview of a fitted `cssr` object: a header #' with the number of selected clusters and features (at the given cutoff), a #' per-cluster table built on top of [printCssDf()], and a placeholder for #' per-family error rate (PFER) error-control content. #' #' The returned object has class "summary.cssr" and an accompanying print method #' ([print.summary.cssr()]). Its `table` element is exactly the data.frame #' returned by [printCssDf()]: one row per selected cluster, sorted by selection #' proportion, with columns ClustName, ClustProtoName (only if the features are #' named), ClustProtoNum, ClustSelProp (the cluster's selection proportion) and #' ClustSize. #' #' If the selection is empty (for example `cutoff = 1` with `min_num_clusts = 0` #' when no cluster reaches the cutoff), `summary.cssr` returns a well-formed #' zero-row object without error: `table` is NULL and the header reports #' "0 clusters / 0 features selected". In this case [printCssDf()] and its helper #' are deliberately NOT called, as they require at least one selected cluster. #' #' The `pfer` element is a documented placeholder (NA) reserved for error-control #' content to be filled in by a future release (issue #87). #' #' @param object An object of class "cssr" (the output of the function [css()]). #' @param cutoff Numeric; only those clusters with selection proportions equal to #' at least cutoff are summarized. Must be between 0 and 1. Default is 0 (in #' which case either all clusters are summarized, or max_num_clusts are, if #' max_num_clusts is specified). #' @param min_num_clusts Integer or numeric; the minimum number of clusters to #' use regardless of cutoff. Default is 1. May be set to 0 to allow a pure #' cutoff-based (threshold) selection that can be empty. #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. Default is NA (in which case max_num_clusts is #' ignored). Because clusters can have tied selection proportions, ties at the #' threshold can cause more than max_num_clusts (or fewer than min_num_clusts) #' clusters to be returned; when the two constraints conflict, max_num_clusts #' takes precedence. #' @param weighting Character; passed to [getCssSelections()] to determine the #' selected features and hence the selected-feature count in the header. As in #' [selected()], it does NOT affect which clusters are selected or the #' per-cluster table. Must be one of "sparse", "weighted_avg", or "simple_avg". #' Default is "sparse". #' @param ... Additional arguments (currently unused). #' @return An object of class "summary.cssr": a named list with elements #' \\item{n_selected_clusts}{Integer; the number of selected clusters.} #' \\item{n_selected_feats}{Integer; the number of selected features.} #' \\item{cutoff}{Numeric; the cutoff that was used.} #' \\item{table}{A data.frame with one row per selected cluster (the output of #' [printCssDf()]), or NULL when the selection is empty.} #' \\item{pfer}{A placeholder (NA) for per-family error rate error-control #' content, to be filled in by a future release (issue #87).} #' @author Gregory Faletto, Jacob Bien #' @seealso [selected()] to extract just the selected clusters or features; #' [getCssSelections()] for the underlying selection; [printCssDf()] for the #' per-cluster data.frame; [print.cssr()] for the analogous printed summary. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters, #' B = 10) #' summary(res) #' @export summary.cssr <- function(object, cutoff=0, min_num_clusts=1, max_num_clusts=NA, weighting="sparse", ...){ stopifnot(inherits(object, "cssr")) # Selected clusters + features. getCssSelections validates all inputs # (checkCutoff / checkWeighting / checkMinNumClusts / checkMaxNumClusts) and # is empty-safe (a clean empty result when e.g. cutoff = 1 and # min_num_clusts = 0). sel <- getCssSelections(object, weighting=weighting, cutoff=cutoff, min_num_clusts=min_num_clusts, max_num_clusts=max_num_clusts) n_selected_clusts <- length(sel$selected_clusts) n_selected_feats <- length(sel$selected_feats) # Empty-selection path: do NOT call printCssDf() / getSelectionPrototypes() # here. Both assert at least one selected cluster (printCssDf: nrow >= 1; # getSelectionPrototypes: n_selected_clusts >= 1) and so would die opaquely # on an empty selection (#107). Return a well-formed zero-row summary. if(n_selected_clusts >= 1){ # Reuse the sel$selected_clusts already computed above instead of a # second identical getCssSelections() inside printCssDf(). Cluster # selection is weighting-invariant, so sel$selected_clusts (for this # weighting) matches the "sparse"-default selection printCssDf() would # recompute -- the resulting table is byte-identical. (#129) clust_table <- buildCssDf(object, sel$selected_clusts) } else{ clust_table <- NULL } out <- list(n_selected_clusts=n_selected_clusts, n_selected_feats=n_selected_feats, cutoff=cutoff, table=clust_table, pfer=NA_real_) class(out) <- "summary.cssr" return(out) } print.summary.cssr() (mirrors the print.cssr() S3-method pattern – roxygen with @export, no @examples): #' @param x An object of class "summary.cssr" (the output of [summary.cssr()]). #' @rdname summary.cssr #' @export print.summary.cssr <- function(x, ...){ cat("Cluster stability selection summary\\n") cat(sprintf("%d cluster%s / %d feature%s selected at cutoff %s\\n", x$n_selected_clusts, if(x$n_selected_clusts == 1) "" else "s", x$n_selected_feats, if(x$n_selected_feats == 1) "" else "s", format(x$cutoff))) if(is.null(x$table)){ cat("(no clusters selected at this cutoff)\\n") } else{ cat("\\n") print.data.frame(x$table, ...) } # PFER placeholder: error-control content to be filled in by issue #87. cat(sprintf("\\nPFER: %s (not yet implemented; see issue #87)\\n", format(x$pfer))) invisible(x) } "],["wrapper-functions.html", "6 Convenient wrapper functions", " 6 Convenient wrapper functions Finally, we provide convenient wrapper functions which yield user-desired output in a single step at the price of flexibility and efficiency. cssSelect() yields a selected set of clusters and features (the same output as getCssSelections()) in a single function call. cssPredict() takes in a training/selection data set as well as a test X. It uses the labeled data to select a set of features and train an OLS model on the selected features, and then it generates predictions on the test set using the fitted model. Besides requiring only a single function call to yield desired output, these wrapper functions also automatically select hyperparameters (lambda used for the lasso, a desired model size, and even selection and training splits for cssPredict()) in a sensible way if these values are not provided by the user. So these functions are very convenient for an end user who wants quick results without getting “under the hood.” The two main disadvantages of these functions are flexibility and computational efficiency. For simplicity of use, these functions do not provide as many options as the component functions they call (for example, min_num_clusts is not an available argument for these models). Further, both of these functions make (computationally intensive) calls to css() internally every time they are called, so these functions are not recommended for users who want to tinker with the model size and other parameters. Instead, it would be more efficient to call css once and then work with the output as desired using the other package functions, which are very efficient given the stored output from css(). cssSelect() and cssPredict() have no new dependencies; they rely only on already-defined functions. cssSelect(): #' Obtain a selected set of clusters and features using cluster stability #' selection #' #' Takes in data X and y and returns a set of clusters (and a set of features) #' that are useful for predicting y from the data in X. This is a wrapper #' function for css and getCssSelections. Using cssSelect is simpler, but it #' has fewer options, and it executes the full (computationally expensive) #' subsampling procedure every time it is called. In contrast, css can be #' called just once, and then getCssSelections can quickly return results using #' different values of cutoff, max_num_clusts, etc. from the calculations done #' in one call to css. #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y A length-n numeric vector containing the responses; `y[i]` is the #' response corresponding to observation `X[i, ]`. (Note that for the css #' function, y does not have to be a numeric response, but for this function, #' the underlying selection procedure is the lasso, so y must be a real-valued #' response.) #' @param clusters Optional; either an integer vector of a list of integer #' vectors; each vector should contain the indices of a cluster of features (a #' subset of 1:p). (If there is only one cluster, clusters can either be a list #' of length 1 or an integer vector.) All of the provided clusters must be #' non-overlapping. Any identical (duplicated) clusters will be removed, keeping #' the first occurrence and its name. Every feature not appearing in any cluster #' will be assumed #' to be unclustered (that is, they will be treated as if they are in a #' "cluster" containing only themselves). If clusters is a list of length 0 (or #' a list only containing clusters of length 1), then css() returns the same #' results as stability selection (so feat_sel_mat will be identical to #' clus_sel_mat). Names for the clusters will be needed later; any clusters that #' are not given names in the list clusters will be given names automatically by #' css. CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). To #' get correct results in this case, please use model.matrix to convert the #' data.frame to a numeric matrix on your own, then provide this matrix and #' cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified, and every feature is assumed to be in a "cluster" #' containing only itself). #' @param lambda Optional; the tuning parameter to be used by the lasso for #' feature selection in each subsample. If lambda is not provided, cssSelect #' will choose one automatically by cross-validation. Default is NA. #' @param cutoff Numeric; cssSelect will only select those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is NA (in which case max_num_clusts are used). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' either cutoff is used to choose the number of clusters, or if cutoff was also #' unspecified, cssSelect chooses max_num_clusts by cross-validation). Because #' clusters can have tied selection proportions, ties at the threshold can cause #' more than max_num_clusts (or fewer than min_num_clusts) clusters to be #' returned; when the two constraints conflict, max_num_clusts takes precedence. #' @param auto_select_size Logical; if TRUE, then max_num_clusts will be #' automatically estimated using the lasso with cross-validation. Default is #' TRUE, though this argument is ignored if either cutoff or max_num_clusts is #' provided. (If desired output is to return all clusters, you should set #' auto_select_size to FALSE and do not provide cutoff or max_num_clusts.) #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Drives both the choice of lambda (when lambda is not provided) and the #' elastic net fit used for feature selection in each subsample. Default is 1 #' (in which case the penalty is the lasso). #' @return A named list with three items. \\item{selected_clusts}{A named list of #' integer vectors; each vector contains the indices of the features in one of #' the selected clusters.} \\item{selected_feats}{A named integer vector; the #' indices of the features with nonzero weights from all of the selected #' clusters. cssSelect uses "sparse" weighting, so a selected cluster #' contributes the member with the highest individual selection proportion, #' along with every other member of that cluster tied with it at that maximum. #' A selected cluster can therefore contribute more than one feature.} #' \\item{weights}{A named list of the same length as selected_clusts. #' Each list element `weights[[j]]` is a numeric vector of the weights to use for #' the jth selected cluster, and it has the same name as the cluster it #' corresponds to.} #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' data <- genClusteredData(n = 80, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- cssSelect(X = data$X, y = data$y, clusters = clusters) #' res$selected_feats #' @export cssSelect <- function(X, y, clusters = list(), lambda=NA, cutoff=NA, max_num_clusts=NA, auto_select_size=TRUE, alpha=1){ # Check inputs (most inputs will be checked by called functions) stopifnot(!is.na(auto_select_size)) stopifnot(length(auto_select_size) == 1) stopifnot(is.logical(auto_select_size)) # Validate alpha up front. This must happen before the NA-lambda branch # below (a user-supplied non-NA lambda skips getLassoLambda and therefore # its own alpha check) and before the bundling step, so that an invalid or # NA alpha is caught here with a clear message rather than deep inside the # subsampling loop. checkAlpha(alpha) stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters, convert_phrase = "the data.frame X") stopifnot(is.matrix(X)) if(!is.numeric(y) & !is.integer(y)){ stop("The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)") } # Reject a non-finite y here (after the domain message above, so that # message is preserved) so the default lambda=NA -> getLassoLambda path # fails fast rather than per-subsample later. checkFiniteY(y, "y") stopifnot(length(lambda) == 1) if(is.na(lambda)){ lambda <- getLassoLambda(X, y, alpha=alpha) } # Bundle alpha into lambda for the elastic-net fit. When alpha == 1 (the # default), leave lambda as a scalar so the pure-lasso path is byte-identical # to the original behavior. if(alpha != 1){ lambda <- c(lambda=lambda, alpha=alpha) } css_results <- css(X, y, lambda, clusters) # If no indication of how to select model size was provided, choose model # size by cross-validation if(is.na(cutoff) & is.na(max_num_clusts)){ if(auto_select_size){ max_num_clusts <- getModelSize(X, y, css_results$clusters, alpha=alpha) } } if(is.na(cutoff)){ cutoff <- 0 } # Get selected features getCssSelections(css_results, weighting="sparse", cutoff=cutoff, min_num_clusts=1, max_num_clusts=max_num_clusts) } cssPredict(): #' Wrapper function to generate predictions from cluster stability selected #' model in one step #' #' Select clusters using cluster stability selection, form cluster #' representatives, fit a linear model, and generate predictions from a matrix #' of unlabeled data. This is a wrapper function for css and getCssPreds. Using #' cssPredict is simpler, but it has fewer options, and it executes the full #' (computationally expensive) subsampling procedure every time it is called. #' In contrast, css can be called just once, and then cssPredict can quickly #' return results for different matrices of new data or using different values #' of cutoff, max_num_clusts, etc. by using the calculations done in one call to #' css. #' #' cssPredict uses "weighted_avg" weighting: each selected cluster is #' represented by a weighted average of the cluster members that were selected #' on at least one subsample, with weights proportional to their individual #' selection proportions. #' (Exception: if no member of a selected cluster was selected on any #' subsample, the weights fall back to a simple average, so all of that #' cluster's members contribute to the representative.) #' #' @param X_train_selec An n x p numeric matrix (preferably) or a data.frame #' (which will be coerced internally to a matrix by the function model.matrix) #' containing the p >= 2 features/predictors. The data from X_train_selec and #' y_train_selec will be split into two parts; half of the data will be used for #' feature selection by cluster stability selection, and half will be used for #' estimating a linear model on the selected cluster representatives. Must not #' contain missing (`NA`) values. #' @param y_train_selec A length-n numeric vector containing the responses; #' `y[i]` is the response corresponding to observation `X[i, ]`. Unlike the more #' general setup of css, y_train_selec must be real-valued because predictions #' will be generated by ordinary least squares. #' @param X_test A numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' the data that will be used to generate predictions. Must contain the same #' features (in the same number of columns) as X_train_selec, and if the columns #' of X_test are named, they must match the names of X_train_selec. #' @param clusters Optional; either an integer vector of a list of integer #' vectors; each vector should contain the indices of a cluster of features (a #' subset of 1:p). (If there is only one cluster, clusters can either be a list #' of length 1 or an integer vector.) All of the provided clusters must be #' non-overlapping. Any identical (duplicated) clusters will be removed, keeping #' the first occurrence and its name. Every feature not appearing in any cluster #' will be assumed #' to be unclustered (that is, they will be treated as if they are in a #' "cluster" containing only themselves). If clusters is a list of length 0 (or #' a list only containing clusters of length 1), then css() returns the same #' results as stability selection (so feat_sel_mat will be identical to #' clus_sel_mat). Names for the clusters will be needed later; any clusters that #' are not given names in the list clusters will be given names automatically by #' css. CAUTION: if the provided X_train_selec (or X_test) is a data.frame that #' contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). To #' get correct results in this case, please use model.matrix to convert the #' data.frame to a numeric matrix on your own, then provide this matrix and #' cluster assignments with respect to this matrix.Default is list() (so no #' clusters are specified, and every feature is assumed to be in a "cluster" #' containing only itself). #' @param lambda Optional; the tuning parameter to be used by the lasso for #' feature selection in each subsample. If lambda is not provided, cssPredict #' will choose one automatically by cross-validation. Default is NA. #' @param cutoff Numeric; cssPredict will make use only of those clusters with #' selection proportions equal to at least cutoff. Must be between 0 and 1. #' Default is NA (in which case, if auto_select_size is TRUE (the default), the #' number of cluster representatives is chosen automatically by cross-validation; #' see auto_select_size). #' @param max_num_clusts Integer or numeric; the maximum number of clusters to #' use regardless of cutoff. (That is, if the chosen cutoff returns more than #' max_num_clusts clusters, the cutoff will be raised until at most #' max_num_clusts clusters are selected.) Default is NA (in which case #' max_num_clusts is ignored). Because clusters can have tied selection #' proportions, ties at the threshold can cause more than max_num_clusts (or #' fewer than min_num_clusts) clusters to be returned; when the two constraints #' conflict, max_num_clusts takes precedence. #' @param train_inds Optional; an integer or numeric vector containing the #' indices of observations in X_train_selec and y_train_selec to set aside for #' model training after #' feature selection. If train_inds is not provided, half of the data will be #' used for feature selection and half for model estimation (chosen at random). #' @param auto_select_size Logical; if TRUE, then max_num_clusts will be #' automatically estimated using the lasso with cross-validation. Default is #' TRUE, though this argument is ignored if either cutoff or max_num_clusts is #' provided. (If desired output is to generate predictions using all clusters, #' you should set auto_select_size to FALSE and do not provide cutoff or #' max_num_clusts.) #' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`. #' Drives both the choice of lambda (when lambda is not provided) and the #' elastic net fit used for feature selection in each subsample. Default is 1 #' (in which case the penalty is the lasso). #' @return A numeric vector of length nrow(X_test) of predictions #' corresponding to the observations from X_test. #' @author Gregory Faletto, Jacob Bien #' @examples #' set.seed(1) #' train <- genClusteredData(n = 80, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' test <- genClusteredData(n = 10, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' preds <- cssPredict(X_train_selec = train$X, y_train_selec = train$y, #' X_test = test$X, clusters = clusters) #' preds #' @export cssPredict <- function(X_train_selec, y_train_selec, X_test, clusters=list(), lambda=NA, cutoff=NA, max_num_clusts=NA, train_inds=NA, auto_select_size=TRUE, alpha=1){ # Check inputs (most inputs will be checked by called functions) if(!is.numeric(y_train_selec) & !is.integer(y_train_selec)){ stop("The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.") } stopifnot(!is.na(auto_select_size)) stopifnot(length(auto_select_size) == 1) stopifnot(is.logical(auto_select_size)) # Validate alpha up front (before the NA-lambda branch and bundling below); # see cssSelect for the ordering rationale. checkAlpha(alpha) stopifnot(is.matrix(X_train_selec) | is.data.frame(X_train_selec)) checkNoNAs(X_train_selec, "X_train_selec") # Reject a non-finite y on the default path (lands after the numeric check # at the top of the function, so the factor-y message there is preserved). checkFiniteY(y_train_selec, "y_train_selec") # Check if x is a matrix; if it's a data.frame, convert to matrix. X_train_selec <- coerceDataFrameToMatrix(X_train_selec, clusters, arg_name = "X_train_selec") stopifnot(is.matrix(X_train_selec)) n <- nrow(X_train_selec) if(any(is.na(train_inds))){ train_inds <- sample(n, size=round(n/2)) } stopifnot(length(lambda) == 1) if(is.na(lambda)){ lambda <- getLassoLambda( X_train_selec[setdiff(1:n, train_inds), , drop = FALSE], y_train_selec[setdiff(1:n, train_inds)], alpha=alpha) } # Bundle alpha into lambda for the elastic-net fit. When alpha == 1 (the # default), leave lambda as a scalar so the pure-lasso path is byte-identical # to the original behavior. if(alpha != 1){ lambda <- c(lambda=lambda, alpha=alpha) } css_results <- css(X=X_train_selec, y=y_train_selec, lambda=lambda, clusters=clusters, train_inds=train_inds) # If no indication of how to select model size was provided, choose model # size by cross-validation if(is.na(cutoff) & is.na(max_num_clusts)){ if(auto_select_size){ max_num_clusts <- getModelSize(X_train_selec[train_inds, , drop = FALSE], y_train_selec[train_inds], css_results$clusters, alpha=alpha) } } if(is.na(cutoff)){ cutoff <- 0 } # Get predictions getCssPreds(css_results, testX=X_test, weighting="weighted_avg", cutoff=cutoff, max_num_clusts=max_num_clusts) } "],["competitor-methods.html", "7 Competitor Methods", " 7 Competitor Methods We also provide implementations of some competitor feature selection methods. We used these in the simulation studies in our paper to compare cluster stability selection to the protolasso (Reid and Tibshirani, 2016) and the cluster representative lasso (Bühlmann et. al. 2013), two other feature selection methods that are designed for data with clustered features. These feature selection methods are in some ways closely related, so their implementations share helper functions. protolasso() processClusterLassoInputs() checks and formats the function inputs getXglmnet() formats the provided design matrix Xglmnet for the lasso as implemented by glmnet (for the protolasso, this means discarding all features from each cluster except the one most highly correlated with the response; for the cluster representative lasso, this means replacing the clustered features with a simple average of the cluster members). checkGetXglmnetInputs() verifies the inputs to getXglmnet() Finally, getClusterSelsFromGlmnet() extracts the relevant output from the results yielded by a glmnet lasso fit. getSelectedSets() takes in a single selected set from Xglmnet and yields a selected feature set in the original feature space (with each selected cluster from Xglmnet replaced by its prototype) as well as a selected set of clusters. clusterRepLasso() The shared core of protolasso() and clusterRepLasso(). The two procedures differ only in how getXglmnet() constructs the design matrix (its type argument); the rest of the body – input handling, the glmnet fit, and extracting selected sets – is identical, so it lives here once. #' Shared implementation of protolasso and clusterRepLasso #' #' Internal helper holding the common body of `protolasso()` and #' `clusterRepLasso()`, which differ only in the `type` passed to `getXglmnet()` #' (the sole point where the two procedures diverge: protolasso discards #' non-prototype cluster members, clusterRepLasso replaces each cluster with its #' representative). #' @param X,y,clusters,nlambda As documented in `protolasso()` / #' `clusterRepLasso()`. #' @param type Character; either "protolasso" or "clusterRepLasso", passed to #' `getXglmnet()` to select the design-matrix construction. #' @return As documented in `protolasso()` / `clusterRepLasso()`. #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd clusterLassoCore <- function(X, y, clusters, nlambda, type){ # Handle and format inputs; get cluster prototypes ret <- processClusterLassoInputs(X, y, clusters, nlambda) x <- ret$x clusters <- ret$clusters prototypes <- ret$prototypes feat_names <- ret$var_names rm(ret) # Format the design matrix for glmnet according to the chosen procedure # (type = "protolasso" or "clusterRepLasso"); see getXglmnet(). X_glmnet <- getXglmnet(x, clusters, type=type, prototypes=prototypes) # getXglmnet returns one column per cluster, so a single all-encompassing # cluster (or a genuine p < 2 input, which processClusterLassoInputs does not # rule out) yields a 1-column design that glmnet cannot fit ("x should be a # matrix with 2 or more columns"). Fail early with a message naming both # degenerate causes instead of surfacing glmnet's opaque error. This catches # both protolasso() and clusterRepLasso(), which route through here. if(ncol(X_glmnet) < 2){ stop("protolasso()/clusterRepLasso() need at least 2 cluster representatives to fit the lasso, but the provided data yields only 1 (all features are in a single cluster, or p < 2).") } # Estimate the lasso on the cluster prototypes / representatives fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=nlambda) nonzero <- glmnet::predict.glmnet(fit, type="nonzero") # predict.glmnet(type = "nonzero") has no stable container across glmnet # versions, and both operations downstream are container-sensitive: unique() # dedupes list ELEMENTS but data.frame ROWS, and getClusterSelsFromGlmnet()'s # lengths() counts per-element lengths but data.frame ROWS PER COLUMN. So a # SINGLE-COLUMN data.frame here does not error--it returns a confidently # wrong set of model sizes (#190). (The multi-column layout happens to # degenerate to the right answer, because no two of its rows can be equal, so # unique() is a no-op on it. Normalise both anyway: the code should not depend # on which of the two arrives.) # # glmnet 5.0 always returns a list. glmnet 4.x returns one only because this # fit supplies no lambda: the auto-generated sequence starts at lambda_max, # where df == 0, so nonzeroCoef()'s nzel() yields NULL for that penalty, # apply() cannot simplify to a matrix, and 4.x's data.frame(which) coercion # is skipped. That is an accident of the sequence, not a contract, so # normalise rather than rely on it. # # The two data.frame layouts are NOT the same, which is why as.list() alone # would be wrong. When every penalty selected the same NUMBER k >= 2 of # features -- the sets themselves may differ, {1,2} and {2,3} qualify -- # apply() gives a k x n_pen matrix and data.frame() lays out one COLUMN per # penalty. When every penalty selected exactly ONE feature, apply() collapses # to a vector and data.frame() gives a single column with one ROW per # penalty--the convention inverts. n_pen tells them apart. # # Do NOT flatten with unlist(). cssLasso() does, correctly, because its # scalar s gives it exactly one slot; this result has one slot per model # size and flattening would merge them (#188). That function's comment # states the rule and already warns against copying its idiom here; this # one is the full account of nonzeroCoef()'s layouts. They are # complementary, not competing. # # n_pen is ncol(fit$beta) only because this call passes no s. With s # supplied, predict.glmnet interpolates to length(s) columns instead and this # derivation breaks--change n_pen to length(s) if that ever happens. n_pen <- ncol(fit$beta) # The ORDER of the two branch predicates is load-bearing. On a square # input (k == n_pen) BOTH are true and the two readings differ, so testing # ncol first is what makes column-major win -- which is correct, because # apply() simplifies to a matrix only with one column per penalty, and # collapses to a vector (hence exactly one column) otherwise. Swapping the # test and the readings together is wrong on square input only, which is # why a fixture of that shape is pinned below. if(is.data.frame(nonzero)){ nonzero_mat <- as.matrix(nonzero) if(ncol(nonzero_mat) == n_pen){ nonzero <- lapply(seq_len(n_pen), function(j){ as.integer(nonzero_mat[, j]) }) } else{ stopifnot(nrow(nonzero_mat) == n_pen) nonzero <- lapply(seq_len(n_pen), function(i){ as.integer(nonzero_mat[i, ]) }) } } # One slot per penalty in the fitted path, on every glmnet version. Any # other container--nonzeroCoef()'s nr == 1 branch, which the # ncol(X_glmnet) < 2 guard above makes unreachable here--stops rather than # being silently misread downstream. stopifnot(is.list(nonzero)) stopifnot(!is.data.frame(nonzero)) stopifnot(identical(length(nonzero), n_pen)) lasso_sets <- unique(nonzero) # Obtain a tidy list of selected sets--one for each model size cluster_sel_results <- getClusterSelsFromGlmnet(lasso_sets, clusters, prototypes, feat_names) return(list(selected_sets=cluster_sel_results$selected_sets, selected_clusts_list=cluster_sel_results$selected_clusts_list, beta=fit$beta)) } protolasso(): #' Select features via the protolasso (Reid and Tibshirani 2016) #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Any identical #' (duplicated) clusters will be removed, keeping the first occurrence and its #' name. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). #' To get correct results in this case, please use model.matrix to convert #' the data.frame to a numeric matrix on your own, then provide this matrix #' and cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the protolasso. Default is 100 (following the default for glmnet). For #' now, nlambda must be at least 2 (using a single lambda is not supported). #' @return A list with three elements. \\item{selected_sets}{A list of integer #' vectors. Entry k of this list contains a selected set (an integer vector) of #' size k yielded by the protolasso (If no set of size k was selected, entry k #' will be empty.)} \\item{selected_clusts_list}{A list; each element of the list #' is a named list of selected clusters. (That is, if a selected set of size k #' was yielded by the protolasso, then `selected_clusts_list[[k]]` is a named #' list of length k, where each member of the list is an integer vector #' of cluster members. In particular, `selected_clusts_lists[[k]][[j]]` will be #' the cluster that contains feature `selected_sets[[k]][j]`.)} \\item{beta}{The #' beta output from glmnet when the lasso was estimated on a matrix of #' prototypes. (See documentation for the function glmnet from the glmnet #' package for details.) The rows of beta correspond, in order, to the clusters #' in the internally reordered clusters list (the provided clusters in the #' supplied order, followed by a singleton cluster for each unclustered feature #' in ascending feature-index order). Each row name is the cluster's name--the #' provided name for a supplied cluster, or an automatically assigned #' `c<position>` name (position in the reordered list, not the feature index) #' for a singleton; a selected cluster's row name coincides with its entry name #' in `selected_clusts_list[[k]]`.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- protolasso(X = data$X, y = data$y, clusters = clusters) #' str(res, max.level = 1) #' @export protolasso <- function(X, y, clusters=list(), nlambda=100){ clusterLassoCore(X, y, clusters, nlambda, type="protolasso") } processClusterLassoInputs(): #' Check the inputs to protolasso and clusterRepLasso, format clusters, and #' identify prototypes for each cluster #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' Default is list() (so no clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the protolasso. Default is 100 (following the default for glmnet). For #' now, nlambda must be at least 2 (using a single lambda is not supported). #' @return A list with four elements. \\item{x}{The provided X, converted to a #' matrix if it was provided as a data.frame, and with column names removed.} #' \\item{clusters}{A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters are #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features will be put in their own "cluster" of size 1).} #' \\item{prototypes}{An integer vector whose length is equal to the number of #' clusters. Entry i is the index of the feature belonging to cluster i that is #' most highly correlated with y (that is, the prototype for the cluster, as in #' the protolasso; see Reid and Tibshirani 2016).} \\item{var_names}{If the #' provided X matrix had column names, the names of the featurrs in the provided #' X matrix. If no names were provided, feat_names will be NA.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd processClusterLassoInputs <- function(X, y, clusters, nlambda){ stopifnot(is.matrix(X) | is.data.frame(X)) checkNoNAs(X, "X") # Check if x is a matrix; if it's a data.frame, convert to matrix. X <- coerceDataFrameToMatrix(X, clusters) stopifnot(is.matrix(X)) feat_names <- as.character(NA) if(!is.null(colnames(X))){ feat_names <- colnames(X) if(any(is.na(feat_names))){ stop("Some features in provided X matrix had valid names and some had NA names; please either name all features in X or remove the names altogether.") } } n <- nrow(X) colnames(X) <- character() stopifnot(is.numeric(y) | is.integer(y)) stopifnot(n == length(y)) stopifnot(all(is.finite(y))) # Check clusters argument clusters <- checkCssClustersInput(clusters) # Format clusters into a list where all features are in exactly one # cluster (any unclustered features are put in their own "cluster" of size # 1). clust_names <- as.character(NA) if(!is.null(names(clusters)) & is.list(clusters)){ clust_names <- names(clusters) } cluster_results <- formatClusters(clusters, p=ncol(X), clust_names=clust_names, get_prototypes=TRUE, x=X, y=y) clusters <- cluster_results$clusters prototypes <- cluster_results$prototypes rm(cluster_results) stopifnot(length(clusters) == length(prototypes)) stopifnot(is.numeric(nlambda) | is.integer(nlambda)) stopifnot(length(nlambda) == 1) stopifnot(!is.na(nlambda)) stopifnot(nlambda >= 2) stopifnot(nlambda == round(nlambda)) return(list(x=X, clusters=clusters, prototypes=prototypes, var_names=feat_names)) } getXglmnet(): #' Converts the provided design matrix to an appropriate format for either the #' protolasso or the cluster representative lasso. #' #' Creates design matrix for glmnet by dealing with clusters (for #' type="protolasso", discards all cluster members except prototype; for #' type="clusterRepLasso", replaces all cluster members with a simple #' average of all the cluster members). #' @param x A numeric matrix; the provided matrix with n observations and p #' features. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters should #' be equal to the number of clusters.) All identified clusters should be #' non-overlapping. All features should appear in exactly one cluster (any #' unclustered features should be put in their own "cluster" of size 1). #' @param type Character; "protolasso" for the protolasso or "clusterRepLasso" #' for the cluster representative lasso. #' @param prototypes Only required for type "protolasso". An integer vector #' whose length is equal to the number of clusters. Entry i should be the #' prototype for cluster i (the feature belonging to cluster i that is most #' highly correlated with y; see Reid and Tibshirani 2016). #' @return A numeric matrix; the design matrix as required for the protolasso or #' cluster representative lasso, prepared for input to glmnet. #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd getXglmnet <- function(x, clusters, type, prototypes=NA){ # Check inputs checkGetXglmnetInputs(x, clusters, type, prototypes) n <- nrow(x) p <- ncol(x) X_glmnet_cols <- vector("list", length(clusters)) for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] if(length(cluster_i) == 1){ X_glmnet_i <- x[, cluster_i] } else{ stopifnot(length(cluster_i) > 1) if(type == "protolasso"){ prototype_ind_i <- which(prototypes %in% cluster_i) stopifnot(length(prototype_ind_i) == 1) prototype_i <- prototypes[prototype_ind_i] X_glmnet_i <- x[, prototype_i] } else { stopifnot(type == "clusterRepLasso") X_glmnet_i <- rowMeans(x[, cluster_i]) } } stopifnot(length(X_glmnet_i) == n) X_glmnet_cols[[i]] <- X_glmnet_i } # do.call(cbind, ...) reproduces cbind's exact type-promotion (and so # preserves the integer storage of an integer x) while avoiding the # O(n*k^2) copying of growing X_glmnet column by column (#58). X_glmnet <- do.call(cbind, X_glmnet_cols) stopifnot(ncol(X_glmnet) == length(clusters)) stopifnot(ncol(X_glmnet) == length(clusters)) # (#158b) name each column with its cluster's name (from the reordered, # formatted clusters list) so glmnet's beta inherits meaningful rownames # matching selected_clusts_list. Column i corresponds to clusters[[i]]. if(!is.null(names(clusters))){ colnames(X_glmnet) <- names(clusters) } # Check output stopifnot(is.matrix(X_glmnet)) stopifnot(nrow(X_glmnet) == n) stopifnot(ncol(X_glmnet) <= p) stopifnot(ncol(X_glmnet) >= 1) return(X_glmnet) } checkGetXglmnetInputs(): #' Verifies the inputs for getXglmnet. #' #' @param x A numeric matrix; the provided matrix with n observations and p #' features. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters should #' be equal to the number of clusters.) All identified clusters should be #' non-overlapping. All features should appear in exactly one cluster (any #' unclustered features should be put in their own "cluster" of size 1). #' @param type Character; "protolasso" for the protolasso or "clusterRepLasso" #' for the cluster representative lasso. #' @param prototypes Only required for type "protolasso". An integer vector #' whose length is equal to the number of clusters. Entry i should be the #' prototype for cluster i (the feature belonging to cluster i that is most #' highly correlated with y; see Reid and Tibshirani 2016). #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. #' @keywords internal #' @noRd checkGetXglmnetInputs <- function(x, clusters, type, prototypes){ stopifnot(is.matrix(x)) stopifnot(is.list(clusters)) stopifnot(all(lengths(clusters) >= 1)) stopifnot(length(type) == 1) stopifnot(is.character(type)) stopifnot(!is.na(type)) stopifnot(type %in% c("protolasso", "clusterRepLasso")) stopifnot(!is.na(prototypes)) stopifnot(is.integer(prototypes)) stopifnot(all(!is.na(prototypes))) stopifnot(length(prototypes) == length(unique(prototypes))) stopifnot(all(prototypes %in% 1:ncol(x))) for(i in 1:length(clusters)){ cluster_i <- clusters[[i]] stopifnot(sum(prototypes %in% cluster_i) == 1) } } getClusterSelsFromGlmnet(): #' Extracts selected clusters and cluster prototypes from the glmnet lasso #' output #' #' @param lasso_sets A list of integer vectors. Each vector represents a set of #' features selected by the lasso for a given value of the penalty parameter #' lambda. The list container is required rather than merely expected: the #' function stops if `lasso_sets` is not a list, or is a data.frame. The #' container only -- element types and lengths are not checked. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features must be in their own "cluster" of size 1). #' @param prototypes An integer vector whose length must be equal to the number #' of clusters. Entry i should be the index of the feature belonging to cluster #' i that is most highly correlated with y (that is, the prototype for the #' cluster, as in the protolasso; see Reid and Tibshirani 2016). #' @param feat_names Character vector; the names of the features in X. (If the #' X provided to protolasso or clusterRepLasso did not have feature names, #' feat_names will be NA.) #' @return A list containing the following items: \\item{selected_sets}{A list of #' integer vectors. Entry k of this list contains a selected set of size k #' yielded by glmnet--each member of the set is the index of a single feature #' from a cluster selected by either the protolasso or the cluster #' representative lasso (the prototype from that cluster--the cluster member #' most highly correlated with y). (If no set of size k was selected, entry k #' will be NULL.)} \\item{selected_clusts_list}{A list of lists; entry k of this #' list is a list of length k of clusters (the clusters that were selected by #' the cluster representative lasso). Again, if no set of size k was selected, #' entry k will be NULL.} #' @author Gregory Faletto, Jacob Bien #' @references Reid, S., & Tibshirani, R. (2016). Sparse regression and marginal #' testing using cluster prototypes. \\emph{Biostatistics}, 17(2), 364–376. #' \\url{https://doi.org/10.1093/biostatistics/kxv049}. \\cr Bühlmann, P., #' Rütimann, P., van de Geer, S., & Zhang, C. H. (2013). Correlated variables in #' regression: Clustering and sparse estimation. #' \\emph{Journal of Statistical Planning and Inference}, 143(11), 1835–1858. #' \\url{https://doi.org/10.1016/j.jspi.2013.05.019}. #' @keywords internal #' @noRd getClusterSelsFromGlmnet <- function(lasso_sets, clusters, prototypes, feat_names){ # lasso_sets must be a list with one slot per penalty; clusterLassoCore() # normalises predict.glmnet()'s output to that shape. A data.frame is also # a list, so it needs its own test--on one, lengths() below would count # rows per column instead of per-slot lengths, and the function would report # model sizes glmnet never selected (#190). stopifnot(is.list(lasso_sets)) stopifnot(!is.data.frame(lasso_sets)) if(any(!is.na(feat_names))){ stopifnot(all(!is.na(feat_names))) } # Compute each set's length once (used both for max_length and the # per-size subset below) instead of re-walking lengths every iteration (#58) set_lengths <- lengths(lasso_sets) # Largest selected set among all those in lasso_sets max_length <- max(set_lengths) # Preparing lists to store selected_sets <- list() selected_clusts_list <- list() for(j in seq_len(max_length)){ # Lasso selected set of size j lasso_sets_j <- lasso_sets[set_lengths == j] # Are there any lasso selected sets of size j? (If not, we will skip to # the next j, and slot j in the list will be empty.) if(length(lasso_sets_j) > 0){ # Select the first set of size j lasso_set_j <- lasso_sets_j[[1]] stopifnot(length(lasso_set_j) == j) ret <- getSelectedSets(lasso_set=lasso_set_j, clusters=clusters, prototypes=prototypes, feat_names=feat_names) selected_sets[[j]] <- ret$selected_set selected_clusts_list[[j]] <- ret$selected_clusts_list rm(ret) } } stopifnot(length(selected_sets) <= max_length) stopifnot(length(selected_clusts_list) <= max_length) return(list(selected_sets=selected_sets, selected_clusts_list=selected_clusts_list)) } getSelectedSets(): #' Converts a selected set from X_glmnet to selected sets and selected clusters #' from the original feature space of X. #' #' @param lasso_set A vector containing the indices of selected cluster #' representatives or prototypes. #' @param clusters A named list where each entry is an integer vector of indices #' of features that are in a common cluster. (The length of list clusters is #' equal to the number of clusters.) All identified clusters must be #' non-overlapping. All features appear in exactly one cluster (any unclustered #' features must be in their own "cluster" of size 1). #' @param prototypes An integer vector whose length must be equal to the number #' of clusters. Entry i should be the index of the feature belonging to cluster #' i that is most highly correlated with y (that is, the prototype for the #' cluster, as in the protolasso). #' @param feat_names Character vector; the names of the features in X. #' @return A list containing two items: \\item{selected_set}{An integer vector #' with length equal to lasso_set containing a set of selected features in the #' original X matrix. (Selections in lasso_set corresponding to a cluster will #' be replaced by the cluster's prototype from X.)} #' \\item{selected_clusts_list}{A named list of integer vectors with length equal #' to selected_set. `selected_clusts_list[[k]]` will be an integer vector #' containing the indices of the features in X that are in the cluster #' containing prototype `selected_set[k]`.} #' @author Gregory Faletto, Jacob Bien #' @keywords internal #' @noRd getSelectedSets <- function(lasso_set, clusters, prototypes, feat_names){ model_size <- length(lasso_set) stopifnot(model_size > 0) stopifnot(length(unique(lasso_set)) == model_size) stopifnot(all(lasso_set <= length(clusters))) selected_set <- integer() selected_clusts_list <- list() # (#158a) preserve each selected cluster's name so selected_clusts_list is # the named list the docs promise (its names match beta's rownames, #158b). clust_names_out <- character(model_size) # Recover features from original feature space for(k in 1:model_size){ selected_cluster_k <- clusters[[lasso_set[k]]] stopifnot(is.integer(selected_cluster_k)) selected_clusts_list[[k]] <- selected_cluster_k if(!is.null(names(clusters))){ clust_names_out[k] <- names(clusters)[lasso_set[k]] } if(length(selected_cluster_k) == 1){ stopifnot(!(selected_cluster_k %in% selected_set)) selected_set <- c(selected_set, selected_cluster_k) } else{ sel_prototype <- which(prototypes %in% selected_cluster_k) stopifnot(length(sel_prototype) == 1) stopifnot(!(prototypes[sel_prototype] %in% selected_set)) selected_set <- c(selected_set, prototypes[sel_prototype]) } } # (#158a) name the returned list with the selected clusters' names so it is # the named list documented for protolasso()/clusterRepLasso(). if(!is.null(names(clusters))){ names(selected_clusts_list) <- clust_names_out } stopifnot(length(selected_set) == model_size) stopifnot(length(unique(selected_set)) == model_size) if(any(!is.na(feat_names))){ names(selected_set) <- feat_names[selected_set] } stopifnot(length(selected_clusts_list) == model_size) all_feats <- unlist(selected_clusts_list) stopifnot(length(all_feats) == length(unique(all_feats))) return(list(selected_set=selected_set, selected_clusts_list=selected_clusts_list)) } clusterRepLasso(): #' Select features via the cluster representative lasso (Bühlmann et. al. 2013) #' #' @param X An n x p numeric matrix (preferably) or a data.frame (which will #' be coerced internally to a matrix by the function model.matrix) containing #' p >= 2 features/predictors. Must not contain missing (`NA`) values. #' @param y The response; A length n numeric (or integer) real-valued vector. #' @param clusters A list of integer vectors; each vector should contain the #' indices of a cluster of features (a subset of 1:p). (If there is only one #' cluster, clusters can either be a list of length 1 or an integer vector.) #' All of the provided clusters must be non-overlapping. Any identical #' (duplicated) clusters will be removed, keeping the first occurrence and its #' name. Every feature not #' appearing in any cluster will be assumed to be unclustered (that is, they #' will be treated as if they are in a "cluster" containing only themselves). #' CAUTION: if the provided X is a data.frame that contains a categorical #' feature with more than two levels, then the resulting matrix made from #' model.matrix will have a different number of columns than the provided #' data.frame, some of the feature numbers will change, and the clusters #' argument will not work properly (in the current version of the package). #' To get correct results in this case, please use model.matrix to convert #' the data.frame to a numeric matrix on your own, then provide this matrix #' and cluster assignments with respect to this matrix. Default is list() (so no #' clusters are specified). #' @param nlambda Integer; the number of lambda values to use in the lasso fit #' for the cluster representative lasso. Default is 100 (following the default #' for glmnet). For now, nlambda must be at least 2 (using a single lambda is #' not supported). #' @return A list with three elements. \\item{selected_sets}{A list of integer #' vectors. Entry k of this list contains a selected set (an integer vector) of #' size k yielded by the lasso--each member of the set is the index of a single #' feature from a cluster selected by the cluster representative lasso (the #' prototype from that cluster--the cluster member most highly correlated with #' y). (If no set of size k was selected, entry k will be empty.)} #' \\item{selected_clusts_list}{A list; each element of the list is a named list #' of selected clusters. (That is, if a selected set of size k was yielded by #' the cluster representative lasso, then `selected_clusts_list[[k]]` is a named #' list of length k, where each member of the list is an integer vector #' of cluster members. Note that `selected_clusts_lists[[k]][[j]]` will be the #' cluster that contains feature `selected_sets[[k]][j]`.)} \\item{beta}{The beta #' output from glmnet when the lasso was estimated on a matrix of cluster #' representatives (simple averages of the cluster members). (See documentation #' for the function glmnet from the glmnet package for details.) The rows of #' beta correspond, in order, to the clusters in the internally reordered #' clusters list (the provided clusters in the supplied order, followed by a #' singleton cluster for each unclustered feature in ascending feature-index #' order). Each row name is the cluster's name--the provided name for a supplied #' cluster, or an automatically assigned `c<position>` name (position in the #' reordered list, not the feature index) for a singleton; a selected cluster's #' row name coincides with its entry name in `selected_clusts_list[[k]]`.} #' @author Gregory Faletto, Jacob Bien #' @references Bühlmann, P., Rütimann, P., van de Geer, S., & Zhang, C. H. #' (2013). Correlated variables in regression: Clustering and sparse estimation. #' \\emph{Journal of Statistical Planning and Inference}, 143(11), 1835–1858. #' \\url{https://doi.org/10.1016/j.jspi.2013.05.019}. \\cr Jerome Friedman, Trevor #' Hastie, Robert Tibshirani (2010). Regularization Paths for Generalized Linear #' Models via Coordinate Descent. \\emph{Journal of Statistical Software}, 33(1) #' 1-22. URL \\url{https://www.jstatsoft.org/v33/i01/}. #' @examples #' set.seed(1) #' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, #' cluster_size = 4, n_clusters = 1, snr = 3) #' clusters <- list(cluster1 = 1:4) #' res <- clusterRepLasso(X = data$X, y = data$y, clusters = clusters) #' str(res, max.level = 1) #' @export clusterRepLasso <- function(X, y, clusters=list(), nlambda=100){ clusterLassoCore(X, y, clusters, nlambda, type="clusterRepLasso") } "],["tests-for-the-core-css-functions.html", "8 Tests for the core css() functions", " 8 Tests for the core css() functions Now that all of the package’s functions have been defined, we collect their tests here, grouped to mirror the definition chapters above. Keeping the tests together at the end lets those chapters read as continuous narrative; because every function is defined before this part, each test runs only after all of its dependencies have been defined. Tests for coerceDataFrameToMatrix(): testthat::test_that("coerceDataFrameToMatrix keeps a single-column data.frame as a matrix (#43)", { # A 1-column data.frame must coerce to a 1-column matrix, not collapse to a # vector (which used to crash with the cryptic "argument is of length zero", # both with and without clusters). num_df <- data.frame(a = as.numeric(1:8)) res_clust <- coerceDataFrameToMatrix(num_df, clusters = list(1)) testthat::expect_true(is.matrix(res_clust)) testthat::expect_equal(dim(res_clust), c(8L, 1L)) res_noclust <- coerceDataFrameToMatrix(num_df, clusters = list()) testthat::expect_true(is.matrix(res_noclust)) testthat::expect_equal(dim(res_noclust), c(8L, 1L)) # A matrix passes through unchanged. m <- matrix(as.numeric(1:8), nrow = 8, ncol = 1) testthat::expect_identical(coerceDataFrameToMatrix(m, clusters = list()), m) # The factor-expansion guard still fires (a >= 3-level factor changes ncol). fac_df <- data.frame(a = factor(c("x", "y", "z", "x", "y", "z", "x", "y"))) testthat::expect_error(coerceDataFrameToMatrix(fac_df, clusters = list(1)), "the number of columns changed", fixed = TRUE) # A non-numeric (character) matrix is rejected (#152). testthat::expect_error( coerceDataFrameToMatrix(matrix(letters[1:6], nrow = 3, ncol = 2), clusters = list()), "must be a numeric matrix", fixed = TRUE) }) ## Test passed with 7 successes. Tests that a non-numeric matrix X is rejected at every X entry point (#152). All seven entry points funnel through coerceDataFrameToMatrix(), so a character matrix errors with the same clear message everywhere instead of silently producing all-zero selections (css) or crashing later (protolasso): testthat::test_that("non-numeric matrix X is rejected at every entry point (#152)", { set.seed(1) cx <- matrix(sample(letters, 20, TRUE), 10, 2) # character matrix testthat::expect_error( css(X = cx, y = stats::rnorm(10), lambda = 0.01, B = 5), "must be a numeric matrix", fixed = TRUE) testthat::expect_error( protolasso(matrix(sample(letters, 40, TRUE), 20, 2), stats::rnorm(20)), "must be a numeric matrix", fixed = TRUE) testthat::expect_error( clusterRepLasso(matrix(sample(letters, 40, TRUE), 20, 2), stats::rnorm(20)), "must be a numeric matrix", fixed = TRUE) # getCssPreds(testX = <character matrix>): build a valid css result on # numeric data, then pass a character testX of the SAME ncol so it # reaches coerceDataFrameToMatrix (not an ncol-mismatch check first). nx <- matrix(stats::rnorm(60), 30, 2) # B = 5 is under checkB()'s B < 10 threshold, so css() deliberately warns # here. Assert it rather than letting it leak into the reporter (#186). # The assignment sits inside expect_warning() because at testthat edition # 3 expect_warning() returns the condition, not the expression's value. testthat::expect_warning( res <- css(X = nx[1:20, ], y = stats::rnorm(20), lambda = 0.01, B = 5), "Small values of B may lead to poor results.", fixed = TRUE) testthat::expect_error( getCssPreds(res, testX = matrix(sample(letters, 20, TRUE), 10, 2), trainX = nx[21:30, ], trainY = stats::rnorm(10)), "must be a numeric matrix", fixed = TRUE) }) ## Test passed with 5 successes. Tests for checkNoNAs(): testthat::test_that("checkNoNAs flags NA/NaN/Inf in a matrix or data.frame and passes clean input", { m_ok <- matrix(as.numeric(1:8), nrow = 4, ncol = 2) testthat::expect_identical(checkNoNAs(m_ok, "X"), m_ok) # returns input invisibly m_na <- m_ok; m_na[2, 1] <- NA testthat::expect_error(checkNoNAs(m_na, "X"), "must not contain missing", fixed = TRUE) # data.frame with a numeric NA is caught too (before any coercion). df_na <- data.frame(a = c(1, NA, 3), b = c(4, 5, 6)) testthat::expect_error(checkNoNAs(df_na, "X"), "must not contain missing", fixed = TRUE) # arg_name appears in the message. testthat::expect_error(checkNoNAs(m_na, "newx"), "newx", fixed = TRUE) # Non-finite values are rejected too (#99): is.na(Inf) is FALSE, so the # previous bare is.na() check let Inf/-Inf slip through into glmnet and the # cluster-representative averaging, silently corrupting results. m_inf <- m_ok; m_inf[2, 1] <- Inf testthat::expect_error(checkNoNAs(m_inf, "X"), "non-finite", fixed = TRUE) m_neginf <- m_ok; m_neginf[3, 2] <- -Inf testthat::expect_error(checkNoNAs(m_neginf, "X"), "non-finite", fixed = TRUE) # NaN is caught by is.na() (is.na(NaN) is TRUE). m_nan <- m_ok; m_nan[1, 1] <- NaN testthat::expect_error(checkNoNAs(m_nan, "X"), "must not contain missing", fixed = TRUE) # data.frame with Inf in a numeric column is rejected too. df_inf <- data.frame(a = c(1, Inf, 3), b = c(4, 5, 6)) testthat::expect_error(checkNoNAs(df_inf, "X"), "non-finite", fixed = TRUE) # A finite data.frame passes through unchanged. df_ok <- data.frame(a = c(1, 2, 3), b = c(4, 5, 6)) testthat::expect_identical(checkNoNAs(df_ok, "X"), df_ok) # A data.frame with non-numeric (factor/character) columns plus clean numeric # columns still passes: the is.infinite() check is per-numeric-column, so it # must not false-positive on non-numeric columns. df_mixed <- data.frame( f = factor(c("x", "y", "z")), s = c("a", "b", "c"), n = c(1, 2, 3), stringsAsFactors = FALSE) testthat::expect_identical(checkNoNAs(df_mixed, "X"), df_mixed) }) ## Test passed with 10 successes. Tests for checkFiniteY(): testthat::test_that("checkFiniteY accepts finite numeric/integer y and rejects non-finite or non-numeric y (#100)", { # Finite numeric and integer y pass, returning the input invisibly. y_num <- as.numeric(1:8) * 0.5 testthat::expect_identical(checkFiniteY(y_num, "y"), y_num) y_int <- 1L:8L testthat::expect_identical(checkFiniteY(y_int, "y"), y_int) testthat::expect_invisible(checkFiniteY(y_num, "y")) # NA, NaN, Inf, -Inf each error with the non-finite message. testthat::expect_error(checkFiniteY(c(1, NA, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, NaN, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, Inf, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) testthat::expect_error(checkFiniteY(c(1, -Inf, 3), "y"), "must not contain missing (NA) or non-finite (Inf) values", fixed = TRUE) # A non-numeric (logical/character) y errors with the numeric message. testthat::expect_error(checkFiniteY(c(TRUE, FALSE, TRUE), "y"), "must be a numeric (real-valued) vector", fixed = TRUE) testthat::expect_error(checkFiniteY(c("a", "b"), "y"), "must be a numeric (real-valued) vector", fixed = TRUE) # arg_name is interpolated into both messages. testthat::expect_error(checkFiniteY(c(1, Inf), "y_train_selec"), "The provided y_train_selec must not contain missing", fixed = TRUE) testthat::expect_error(checkFiniteY(c(TRUE, FALSE), "y_train_selec"), "The provided y_train_selec must be a numeric", fixed = TRUE) }) ## Test passed with 11 successes. tests for checkCssClustersInput: testthat::test_that("checkCssClustersInput works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) res <- checkCssClustersInput(good_clusters) # clusters testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), length(names(res))) testthat::expect_equal(length(res), length(unique(names(res)))) testthat::expect_true(all(!is.na(names(res)))) testthat::expect_true(all(!is.null(names(res)))) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) res <- checkCssClustersInput(unnamed_clusters) # clusters testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) testthat::expect_error(checkCssClustersInput(list(1:4, 4:6)), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): the result is identical # to passing the cluster only once. testthat::expect_identical(checkCssClustersInput(list(2:3, 2:3)), list(2:3)) testthat::expect_error(checkCssClustersInput(list(2:3, as.integer(NA))), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(list(2:3, c(4, 4, 5))), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(list(2:3, -1)), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkCssClustersInput(c(0.4, 0.6)), "all(clusters == round(clusters)) is not TRUE", fixed=TRUE) # Single cluster res_sing_clust <- checkCssClustersInput(2:5) testthat::expect_equal(length(res_sing_clust), 4) }) ## Test passed with 17 successes. Tests for checkY(): testthat::test_that("checkY works", { testthat::expect_null(checkY(as.numeric(1:20)*.1, 20)) testthat::expect_null(checkY(1L:15L, 15)) testthat::expect_error(checkY(1:7, 8), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(checkY(1:7, -7), "n > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkY(rep(as.numeric(NA), 13), 13), "all(is.finite(y)) is not TRUE", fixed=TRUE) # Inf is now rejected too (previously all(!is.na(y)) missed it) (#100) testthat::expect_error(checkY(c(1, Inf, 3), 3), "all(is.finite(y)) is not TRUE", fixed=TRUE) testthat::expect_error(checkY(rep(5.2, 9), 9), "length(unique(y)) > 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkY(c(TRUE, FALSE, TRUE), 3), "is.numeric(y) | is.integer(y) is not TRUE", fixed=TRUE) }) ## Test passed with 8 successes. Tests for checkFormatClustersInput(): testthat::test_that("checkFormatClustersInput works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) res <- checkFormatClustersInput(good_clusters, p=10, clust_names=c("red_cluster", "green_cluster"), get_prototypes=FALSE, x=NA, y=NA, R=NA) testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) res <- checkFormatClustersInput(unnamed_clusters, p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA) # clusters testthat::expect_true(is.list(res)) clust_feats <- integer() for(i in 1:length(res)){ clust_feats <- c(clust_feats, res[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:8))) testthat::expect_error(checkFormatClustersInput(list(1:4, 4:6), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "length(intersect(clusters[[i]], clusters[[j]])) == 0 is not TRUE", fixed=TRUE) # Duplicate clusters are now silently removed (#156). testthat::expect_identical(checkFormatClustersInput(list(2:3, 2:3), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), list(2:3)) testthat::expect_error(checkFormatClustersInput(list(2:3, as.integer(NA)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "Must specify one of clusters or R (or does one of these provided inputs contain NA?)", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(2:3, c(4, 4, 5)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(1:4, -1), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkFormatClustersInput(list(1:4, c(2.3, 1.2)), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA), "is.integer(clusters[[i]]) is not TRUE", fixed=TRUE) # Single cluster testthat::expect_true(is.list(checkFormatClustersInput(c(1:5), p=10, clust_names=NA, get_prototypes=FALSE, x=NA, y=NA, R=NA))) }) ## Test passed with 13 successes. Tests for checkClusters(): testthat::test_that("checkClusters works", { good_clusters <- list(c1=1L:5L, c2=6L:8L, c3=9L) testthat::expect_null(checkClusters(good_clusters, 9)) testthat::expect_error(checkClusters(good_clusters, 10), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(1L:10L, 10), "is.list(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=integer()), 9), "all(lengths(clusters) >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=as.integer(NA)), 9), "all(!is.na(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=9L, c2=6L:8L), 9), "n_clusters == length(unique(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkClusters(list(c1=1L:5L, c2=6L:8L, c3=10L), 9), "all(all_clustered_feats <= p) is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Tests for identifyPrototype(): testthat::test_that("identifyPrototype works", { testthat::expect_identical(identifyPrototype(10L, "a", 5), 10L) n <- 10 p <- 5 set.seed(9834) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] testthat::expect_equal(identifyPrototype(as.integer(p), X, y), p) testthat::expect_equal(identifyPrototype(2L, X, y), 2) testthat::expect_equal(identifyPrototype(as.integer(2:p), X, y), p) testthat::expect_error(identifyPrototype(as.integer(2:p), y, X), "incorrect number of dimensions", fixed=TRUE) y2 <- rnorm(n) res <- identifyPrototype(c(2L, 3L), X, y2) testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 1) testthat::expect_true(res %in% c(2L, 3L)) }) testthat::test_that("identifyPrototype handles a constant cluster member silently (#59)", { # A constant column has undefined correlation; the vectorized cor() path # returns 0 for it -- and SILENTLY (base cor() warns "the standard deviation # is zero" on a constant column; identifyPrototype now suppresses that to # preserve the silent-0 contract). n <- 12 set.seed(7321) varying <- stats::rnorm(n) # Column 1 is constant; column 2 equals y (perfectly correlated). x <- cbind(rep(1.5, n), varying) y <- varying # The prototype must be the varying member (2), never the constant column (1). testthat::expect_identical(identifyPrototype(c(1L, 2L), x, y), 2L) # And no "standard deviation is zero" warning may leak. testthat::expect_silent(identifyPrototype(c(1L, 2L), x, y)) }) testthat::test_that("identifyPrototype warns on a constant response y (#67)", { # Moved from the removed helper's test: a constant y makes every # cluster-member correlation undefined, and identifyPrototype warns. set.seed(5417) X <- matrix(stats::rnorm(8 * 2), nrow = 8, ncol = 2) y_const <- rep(2.5, 8) testthat::expect_warning( identifyPrototype(c(1L, 2L), X, y_const), "identifyPrototype: the response y has only one unique value", fixed = TRUE) }) testthat::test_that("identifyPrototype selects by absolute correlation (#67)", { # The prototype is the member with the largest ABSOLUTE correlation with y, so # a near-perfectly NEGATIVELY correlated member must beat a weak positive one. set.seed(6708) n <- 20 y <- stats::rnorm(n) X <- cbind(-y, y + stats::rnorm(n, sd = 4)) # col 1: cor=-1; col 2: weak +cor # abs() => col 1 (|cor|=1) wins despite its negative sign. testthat::expect_identical(identifyPrototype(c(1L, 2L), X, y), 1L) }) ## Test passed with 8 successes. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 1 success. Tests for getPrototypes() testthat::test_that("getPrototypes works", { n <- 10 p <- 5 set.seed(902689) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] testthat::expect_identical(getPrototypes(list(1L, 2L, 3L, 4L, 5L), X, y), 1:5) testthat::expect_identical(getPrototypes(list(1L:5L), X, y), 5L) testthat::expect_identical(getPrototypes(list(1L, 2L:5L), X, y), c(1L, 5L)) testthat::expect_identical(getPrototypes(list(3L:5L), X, y), 5L) y2 <- rnorm(n) res <- getPrototypes(list(1L, c(2L, 3L), c(4L, 5L)), X, y2) testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(res[1], 1L) testthat::expect_true(res[2] %in% c(2L, 3L)) testthat::expect_true(res[3] %in% c(4L, 5L)) testthat::expect_error(getPrototypes(list(1L, 2L, 3L, 4L, 5L), y, X), "is.matrix(x) is not TRUE", fixed=TRUE) testthat::expect_error(getPrototypes(list(1L, 2L, 3L, 4L, 5L), X, y[1:9]), "n == length(y) is not TRUE", fixed=TRUE) }) ## Test passed with 11 successes. Finally, tests for formatClusters(): testthat::test_that("formatClusters works", { # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1:3, 5:8) res <- formatClusters(good_clusters, p=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("clusters", "multiple")) # Clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), 5) testthat::expect_equal(5, length(names(res$clusters))) testthat::expect_equal(5, length(unique(names(res$clusters)))) testthat::expect_true("red_cluster" %in% names(res$clusters)) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) testthat::expect_true(all(names(res$clusters) != "")) clust_feats <- integer() true_list <- list(1:3, 5:8, 4, 9, 10) for(i in 1:length(res$clusters)){ testthat::expect_true(is.integer(res$clusters[[i]])) testthat::expect_equal(length(intersect(clust_feats, res$clusters[[i]])), 0) testthat::expect_true(all(res$clusters[[i]] %in% 1:10)) testthat::expect_equal(length(res$clusters[[i]]), length(unique(res$clusters[[i]]))) testthat::expect_true(all(res$clusters[[i]] == true_list[[i]])) clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), 10) testthat::expect_equal(10, length(unique(clust_feats))) testthat::expect_equal(10, length(intersect(clust_feats, 1:10))) # Multiple testthat::expect_true(res$multiple) testthat::expect_false(formatClusters(3:5, p=10)$multiple) ## Trying other inputs testthat::expect_error(formatClusters(list(3:7, 7:10), p=15), "length(intersect(clusters[[i]], clusters[[j]])) == 0 is not TRUE", fixed=TRUE) # Duplicate clusters are now silently removed (#156): dropping the duplicate # 5:8 leaves the same 6 formatted clusters (5:8 plus five singletons) as # passing 5:8 once, with multiple = FALSE and 5:8 appearing exactly once. dedup_fc <- formatClusters(list(5:8, 5:8), p=9) testthat::expect_identical(dedup_fc, formatClusters(list(5:8), p=9)) testthat::expect_equal(length(dedup_fc$clusters), 6) testthat::expect_false(dedup_fc$multiple) testthat::expect_equal(sum(vapply(dedup_fc$clusters, function(z) identical(as.integer(z), 5:8), logical(1))), 1) # Out-of-range cluster index is now caught up front by checkFormatClustersInput # (#104, L3) with a message naming the offending index and p, instead of the # downstream cryptic length(all_clustered_feats) == p stopifnot. testthat::expect_error(formatClusters(list(5:8), p=7), "Cluster index 8 exceeds the number of features (p = 7).", fixed=TRUE) testthat::expect_error(formatClusters(list(2:3, as.integer(NA)), p=10), "Must specify one of clusters or R (or does one of these provided inputs contain NA?)", fixed=TRUE) testthat::expect_error(formatClusters(list(2:3, c(4, 4, 5)), p=8), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(list(1:4, -1), p=10), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(list(1:4, c(2.3, 1.2))), "is.integer(clusters[[i]]) is not TRUE", fixed=TRUE) ### Test prototypes feature n <- 8 p <- 6 set.seed(690289) X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- X[, p] res <- formatClusters(clusters=list(), p=p, get_prototypes=TRUE, x=X, y=y) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("clusters", "multiple", "prototypes")) testthat::expect_true(is.integer(res$prototypes)) testthat::expect_identical(res$prototypes, 1:p) testthat::expect_equal(formatClusters(clusters=1:p, p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, p) testthat::expect_identical(formatClusters(clusters=list(1L, 2L:p), p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, as.integer(c(1, p))) testthat::expect_identical(formatClusters(clusters=3L:p, p=p, get_prototypes=TRUE, x=X, y=y)$prototypes, as.integer(c(p, 1, 2))) y2 <- rnorm(n) res <- formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=X, y=y2)$prototypes testthat::expect_true(is.integer(res)) testthat::expect_equal(length(res), 4) testthat::expect_true(res[1] %in% c(2L, 3L)) testthat::expect_true(res[2] %in% c(4L, 5L)) testthat::expect_equal(res[3], 1L) testthat::expect_equal(res[4], p) testthat::expect_error(formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=y2, y=X), "is.matrix(x) is not TRUE", fixed=TRUE) testthat::expect_error(formatClusters(clusters=list(2:3, 4:5), p=p, get_prototypes=TRUE, x=X, y=y2[1:(n-1)]), "n == length(y) is not TRUE", fixed=TRUE) }) ## Test passed with 65 successes. Tests for checkSamplingType(): testthat::test_that("checkSamplingType works", { testthat::expect_null(checkSamplingType("SS")) testthat::expect_error(checkSamplingType("MB"), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) testthat::expect_error(checkSamplingType(c("SS", "SS")), "length(sampling_type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkSamplingType(1), "is.character(sampling_type) is not TRUE", fixed=TRUE) testthat::expect_error(checkSamplingType(as.character(NA)), "!is.na(sampling_type) is not TRUE", fixed=TRUE) }) ## Test passed with 5 successes. Tests for checkB(): testthat::test_that("checkB works", { testthat::expect_null(checkB(1500)) testthat::expect_null(checkB(15)) testthat::expect_error(checkB("B"), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(20:25), "length(B) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkB(as.integer(NA)), "!is.na(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(1.2), "B == round(B) is not TRUE", fixed=TRUE) testthat::expect_error(checkB(-100), "B > 0 is not TRUE", fixed=TRUE) testthat::expect_warning(checkB(5), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_warning(checkB(2200), "Large values of B may require long computation times.", fixed=TRUE) }) ## Test passed with 9 successes. Tests for checkAlpha(): testthat::test_that("checkAlpha validates alpha in (0, 1] (#72)", { testthat::expect_null(checkAlpha(1)) testthat::expect_null(checkAlpha(0.5)) testthat::expect_error(checkAlpha("0.5"), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(c(0.5, 0.6)), "length(alpha) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(NA_real_), "!is.na(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(0), "alpha > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkAlpha(1.5), "alpha <= 1 is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Tests for checkPropFeatsRemove(): testthat::test_that("checkPropFeatsRemove works", { testthat::expect_null(checkPropFeatsRemove(0, 5)) testthat::expect_null(checkPropFeatsRemove(.3, 10)) testthat::expect_error(checkPropFeatsRemove(1, 3), "prop_feats_remove >= 0 & prop_feats_remove < 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(c(.5, .6), 17), "length(prop_feats_remove) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(".3", 99), "is.numeric(prop_feats_remove) | is.integer(prop_feats_remove) is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(as.numeric(NA), 172), "!is.na(prop_feats_remove) is not TRUE", fixed=TRUE) testthat::expect_error(checkPropFeatsRemove(.1, 1), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 7 successes. Finally, tests for checkCssInputs(): testthat::test_that("checkCssInputs works", { set.seed(80526) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L # , c4=10:11 ) res <- checkCssInputs(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) # Basic output testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("feat_names", "X", "clusters")) # feat_names testthat::expect_true(is.character(res$feat_names)) testthat::expect_true(is.na(res$feat_names)) testthat::expect_equal(length(res$feat_names), 1) # X testthat::expect_true(is.matrix(res$X)) testthat::expect_true(all(!is.na(res$X))) testthat::expect_true(is.numeric(res$X)) testthat::expect_equal(ncol(res$X), 11) testthat::expect_equal(nrow(res$X), 15) # clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), length(names(res$clusters))) testthat::expect_equal(length(res$clusters), length(unique(names(res$clusters)))) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) clust_feats <- integer() for(i in 1:length(res$clusters)){ clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:11))) # Regression test: train_inds with an out-of-range index (> n) must be # rejected. Previously the upper-bound check was a no-op due to a misplaced # parenthesis (all(train_inds) <= n instead of all(train_inds <= n)), so # out-of-range indices were silently accepted. (n = 15 here; 16 is invalid.) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = c(1L, 2L, 16L), num_cores = 1L)) ## Trying other inputs # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } res_fitfun <- checkCssInputs(X=x, y=y, lambda=x, clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) testthat::expect_true(is.list(res_fitfun)) # Single cluster res_sing_clust <- checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) testthat::expect_true(is.list(res_sing_clust)) testthat::expect_equal(length(res_sing_clust$clusters), 11 - 3 + 1) testthat::expect_true(length(unique(names(res_sing_clust$clusters))) == 11 - 3 + 1) testthat::expect_true(all(!is.na(names(res_sing_clust$clusters)))) testthat::expect_true(all(!is.null(names(res_sing_clust$clusters)))) # Other sampling types testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "MB", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, fitfun = testFitfun, sampling_type = "S", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L)) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = 2, B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "is.character(sampling_type) is not TRUE", fixed=TRUE) # B testthat::expect_warning(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = 5, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_error(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun = testFitfun, sampling_type = "SS", B = "foo", prop_feats_remove = 0, train_inds = integer(), num_cores = 1L), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) # prop_feats_remove testthat::expect_true(is.list(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun=testFitfun, sampling_type = "SS", B = 12, prop_feats_remove = 0.3, train_inds = integer(), num_cores = 1L))) # Use train_inds argument testthat::expect_true(is.list(checkCssInputs(X=x, y=y, lambda=c("foo", "bar", as.character(NA)), clusters=1:3, fitfun=testFitfun, sampling_type = "SS", B = 12, prop_feats_remove = 0.3, train_inds = 11:15, num_cores = 1L))) }) ## Test passed with 31 successes. Tests for checkCssLoopOutput(): testthat::test_that("checkCssLoopOutput works", { testthat::expect_null(checkCssLoopOutput(selected=1:5, p=6, feats_on_subsamp=1:6)) testthat::expect_error(checkCssLoopOutput(selected=1:5, p=4, feats_on_subsamp=1:6), "The provided feature selection method fitfun returned a vector of selected features longer than p on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=1:5, p=7, feats_on_subsamp=1:4), "The provided feature selection method somehow selected features that were not provided for it to consider.", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(1, 2, 3, 4.4, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun failed to return a vector of valid (integer) indices on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=rep(1, 3), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing repeated indices on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(-1, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c(0, 5), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector of selected features containing a non-positive index on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=as.integer(NA), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun returned a vector containing NA values on (at least) one subsample", fixed=TRUE) testthat::expect_error(checkCssLoopOutput(selected=c("1", "2", "3"), p=7, feats_on_subsamp=1:7), "The provided feature selection method fitfun failed to return an integer or numeric vector on (at least) one subsample", fixed=TRUE) testthat::expect_error( checkCssLoopOutput(selected=c(TRUE, FALSE), p=7, feats_on_subsamp=1:7), "returned a logical vector", fixed=TRUE) testthat::expect_error( checkCssLoopOutput(selected=NULL, p=7, feats_on_subsamp=1:7), "returned NULL", fixed=TRUE) }) ## Test passed with 11 successes. Tests for fitfunFailureMessage(): testthat::test_that("fitfunFailureMessage surfaces the cause and subsample index (#73)", { # try-error path: the wrapped condition message is surfaced (this is what # getSelMatrix actually receives from mclapply under forking). te <- structure("Error\\n", class = "try-error", condition = simpleError("fitfun returned a character vector")) msg <- fitfunFailureMessage(te, 4L) testthat::expect_match(msg, "subsample 4", fixed = TRUE) testthat::expect_match(msg, "fitfun returned a character vector", fixed = TRUE) # defensive non-try-error fallback: the class is reported. msg2 <- fitfunFailureMessage("not an integer vector", 2L) testthat::expect_match(msg2, "class character", fixed = TRUE) testthat::expect_match(msg2, "subsample 2", fixed = TRUE) testthat::expect_match(msg2, "integer vector of selected feature indices", fixed = TRUE) }) ## Test passed with 5 successes. Tests for checkCssLassoInputs(): testthat::test_that("checkCssLassoInputs works", { set.seed(761) x <- matrix(stats::rnorm(15*4), nrow=15, ncol=4) y <- stats::rnorm(15) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=0.01)) testthat::expect_error(checkCssLassoInputs(X=x, y=logical(15), lambda=0.05), "For method cssLasso, y must be a numeric or integer vector.", fixed=TRUE) # Integer y is accepted (is.numeric(1L) is TRUE; the | !is.integer guard # makes the validator read uniformly with the other entry points). Regression # test for issue #13 -- this is NOT a behavior change, integer y always worked. testthat::expect_null(checkCssLassoInputs(X=x, y=as.integer(round(y * 10)), lambda=0.01)) testthat::expect_error(checkCssLassoInputs(X=x[1:13, ], y=y, lambda=0.01), "For method cssLasso, y must be a vector of length equal to nrow(X).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=rep(1.2, 15), lambda=0.05), "Subsample with only one unique value of y detected: for the default cssLasso, every subsample of y (of size floor(n/2)) must have more than one unique value. css draws random subsamples, so this abort is seed-dependent and becomes more likely as B grows. It indicates that y is too discrete for the default cssLasso--supply a less discrete (more continuous) response, or pass a custom fitfun that tolerates a constant-y subsample.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=TRUE), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=as.numeric(NA)), "NA detected in provided lambda input to cssLasso", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=x), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=numeric()), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) # Bundled c(lambda=, alpha=) form (elastic net) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0.5))) # Order-insensitive (setequal on names) testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(alpha=0.5, lambda=0.1))) # alpha at the boundary 1 is allowed testthat::expect_null(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=1))) # Unnamed length-2 vector is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(0.1, 0.5)), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0)), "For method cssLasso, the alpha component of lambda must be in (0, 1].", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=1.2)), "For method cssLasso, the alpha component of lambda must be in (0, 1].", fixed=TRUE) # Length-3 vector is rejected testthat::expect_error(checkCssLassoInputs(X=x, y=y, lambda=c(lambda=0.1, alpha=0.5, extra=0.3)), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) }) ## Test passed with 18 successes. Tests for cssLasso() confirming that the elastic net mixing parameter alpha, bundled into lambda as c(lambda=, alpha=), actually changes which features are selected (and that the default pure-lasso path is unchanged). On a design with a correlated block of relevant features, a smaller alpha (more ridge-like) pulls in the correlated block partners that the pure lasso drops, so the elastic-net selected set is a strict superset of the lasso selected set: testthat::test_that("cssLasso alpha (bundled in lambda) drives selection", { # Correlated-block design: features 1-4 are relevant and share a common # latent factor at correlation rho; features 5-20 are irrelevant noise. set.seed(1) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), n, p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) L <- 3.72251 s_lasso <- cssLasso(Z, y, lambda=c(lambda=L, alpha=1)) s_enet <- cssLasso(Z, y, lambda=c(lambda=L, alpha=0.2)) # Pure lasso selects only the two strongest block members; the elastic net # pulls in the full correlated block. testthat::expect_identical(s_lasso, c(3L, 4L)) testthat::expect_identical(s_enet, c(1L, 2L, 3L, 4L)) # The elastic-net set is a strict superset of the lasso set (the round-2 # cosmetic: robust to L within +/-10%). testthat::expect_true(all(s_lasso %in% s_enet)) testthat::expect_true(length(setdiff(s_enet, s_lasso)) > 0) # Back-compatibility: a scalar lambda is byte-identical to the bundled form # with alpha = 1 (the default pure-lasso path is unchanged). testthat::expect_identical(cssLasso(Z, y, lambda=L), cssLasso(Z, y, lambda=c(lambda=L, alpha=1))) }) ## Test passed with 5 successes. Tests for cssLoop() (had to define checkCssLassoInputs() first): testthat::test_that("cssLoop works", { set.seed(89134) x <- matrix(stats::rnorm(9*8), nrow=9, ncol=8) y <- stats::rnorm(9) output <- cssLoop(input=1L:4L, x=x, y=y, lambda=0.05, fitfun=cssLasso) testthat::expect_true(is.integer(output)) testthat::expect_equal(length(output), length(unique(output))) testthat::expect_true(length(output) <= 8) testthat::expect_true(all(output >= 1)) testthat::expect_true(all(output <= 8)) testthat::expect_error(cssLoop(input=1L:6L, x=x, y=y, lambda=0.05, fitfun=cssLasso), "floor(n/2) == length(subsample) is not TRUE", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=y[1:8], lambda=0.05, fitfun=cssLasso), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=logical(9), lambda=0.05, fitfun=cssLasso), "For method cssLasso, y must be a numeric or integer vector.", fixed=TRUE) testthat::expect_error(cssLoop(input=1L:4L, x=x, y=y, lambda=x, fitfun=cssLasso), "For method cssLasso, lambda must be either a single nonnegative numeric or a named length-2 numeric vector c(lambda=<value>, alpha=<value>).", fixed=TRUE) # Test other input format alt_input <- list("subsample"=2:5, "feats_to_keep"=c(FALSE, rep(TRUE, 4), rep(FALSE, 2), TRUE)) output2 <- cssLoop(input=alt_input, x=x, y=y, lambda=0.08, fitfun=cssLasso) testthat::expect_true(is.integer(output2)) testthat::expect_equal(length(output2), length(unique(output2))) testthat::expect_true(length(output2) <= 8) testthat::expect_true(all(output2 %in% c(2, 3, 4, 5, 8))) testthat::expect_error(cssLoop(input= list("subsample"=2:5, "feats_to_keep"=c(FALSE, rep(TRUE, 4), rep(FALSE, 2))), x=x, y=y, lambda=0.08, fitfun=cssLasso), "length(feats_to_keep) == p is not TRUE", fixed=TRUE) # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) and nonsense y testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } testthat::expect_true(is.integer(cssLoop(input=1L:4L, x=x, y=y, lambda=TRUE, fitfun=testFitfun))) testthat::expect_true(is.integer(cssLoop(input=1L:4L, x=x, y=character(9), lambda=.05, fitfun=testFitfun))) }) ## Test passed with 16 successes. cssLoop() must validate the raw fitfun return against its documented contract before remapping to original feature indices, so that natural contract violations error loudly instead of silently corrupting the selection matrix (#151): testthat::test_that("cssLoop validates the raw fitfun return before remapping (#151)", { set.seed(1) n <- 40 p <- 6 x <- matrix(stats::rnorm(n * p), n, p) y <- stats::rnorm(n) subsample <- as.integer(1:(n %/% 2)) feats_to_keep <- c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE) # p_sub = 4 input <- list(subsample = subsample, feats_to_keep = feats_to_keep) mk <- function(val) function(X, y, lambda) val # fitfun returning a fixed value # Each invalid raw return must error (was silently wrong on main #151): testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(-1L))) # non-positive testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(c(TRUE, FALSE))), # logical "logical vector", fixed = TRUE) testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(1.5))) # fractional testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(NULL)), # NULL "NULL", fixed = TRUE) # 5 > p_sub = 4; on main this errors but MIS-reports "NA values" (post-remap # NA). Asserting the message makes this a real regression test AND locks in # the cosmetic fix. testthat::expect_error(cssLoop(input, x, y, lambda = 0.1, fitfun = mk(5L)), "index greater than ncol(X)", fixed = TRUE) # Valid raw returns still work and remap correctly: testthat::expect_equal( cssLoop(input, x, y, lambda = 0.1, fitfun = mk(integer(0))), # select nothing integer(0)) testthat::expect_equal( cssLoop(input, x, y, lambda = 0.1, fitfun = mk(c(1L, 3L))), # raw cols 1,3 ... as.integer(which(feats_to_keep)[c(1L, 3L)])) # ... remap to 1,4 }) ## Test passed with 7 successes. Tests for checkGetClusterSelMatrixInput(): testthat::test_that("checkGetClusterSelMatrixInput works", { good_clusters <- list(happy=1L:8L, sad=9L:10L, med=11L) res <- matrix(sample(c(0, 1), size=6*11, replace=TRUE), nrow=6, ncol=11) testthat::expect_null(checkGetClusterSelMatrixInput(good_clusters, res)) testthat::expect_error(checkGetClusterSelMatrixInput(list(happy=1L:8L, med=11L), res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, 1:9), "is.matrix(res) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, res + .3), "all(res %in% c(0, 1)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(good_clusters, res[, 1:9]), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(1L:10L, res), "is.list(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=integer()), res), "all(lengths(clusters) >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c4=as.integer(NA)), res), "all(!is.na(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=9L, c2=6L:8L), res), "n_clusters == length(unique(clusters)) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetClusterSelMatrixInput(list(c1=1L:5L, c2=6L:8L, c3=14L), res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) }) ## Test passed with 10 successes. Tests for createSubsamples(): testthat::test_that("createSubsamples returns properly-named elements with feature removal (#69)", { set.seed(692) res <- createSubsamples(n = 30, p = 8, B = 5, sampling_type = "SS", prop_feats_remove = 0.3) testthat::expect_equal(length(res), 2L * 5L) # SS -> 2B elements # Every element is a named list(subsample, feats_to_keep) -- the invariant the # (now-meaningful) output stopifnot guards. testthat::expect_true(all(vapply(res, function(s) identical(names(s), c("subsample", "feats_to_keep")), logical(1)))) }) testthat::test_that("createSubsamples copies feats_to_keep onto each SS complementary pair (#128)", { set.seed(128) res <- createSubsamples(n = 30, p = 20, B = 5, sampling_type = "SS", prop_feats_remove = 0.5) # SS with feature removal -> 2B elements. testthat::expect_equal(length(res), 10L) # Each complementary pair (i, B + i) must share the SAME feats_to_keep -- the # Shah-Samworth pairing guarantee (createSubsamples copies subsample i's mask # onto its pair B + i). With p = 20, two independent rbinom draws would match # with probability ~2^-20 (~1e-6), so the identity below genuinely exercises # the copy rather than passing by coincidence. Every subsample must also retain # >= 2 features (the while-loop guarantee). for(i in 1:5){ testthat::expect_identical(res[[5L + i]]$feats_to_keep, res[[i]]$feats_to_keep) testthat::expect_gte(sum(res[[i]]$feats_to_keep), 2) testthat::expect_gte(sum(res[[5L + i]]$feats_to_keep), 2) } }) testthat::test_that("createSubsamples works", { res <- createSubsamples(n=20L, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 2*11) testthat::expect_true(all(lengths(res) == 20/2)) testthat::expect_equal(length(unique(res[[13]])), 20/2) set <- res[[4]] comp_set <- res[[4 + 11]] testthat::expect_equal(length(intersect(set, comp_set)), 0) testthat::expect_equal(length(union(set, comp_set)), length(c(set, comp_set))) testthat::expect_equal(20, length(c(set, comp_set))) # Try odd n res_odd <- createSubsamples(n=19L, p=23L, B=13L, sampling_type="SS", prop_feats_remove=0) testthat::expect_true(is.list(res_odd)) testthat::expect_equal(length(res_odd), 2*13) testthat::expect_true(all(lengths(res_odd) == floor(19/2))) testthat::expect_equal(length(unique(res_odd[[3]])), floor(19/2)) set_odd <- res_odd[[2]] comp_set_odd <- res_odd[[2 + 13]] testthat::expect_equal(length(intersect(set_odd, comp_set_odd)), 0) testthat::expect_equal(length(union(set_odd, comp_set_odd)), length(c(set_odd, comp_set_odd))) testthat::expect_equal(19 - 1, length(c(set_odd, comp_set_odd))) testthat::expect_error(createSubsamples(n=20L, p=5L, B=11L, sampling_type="MB", prop_feats_remove=0), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # misspecified sampling_type (not specifying error because contains quotation # marks) testthat::expect_error(createSubsamples(n=20L, p=5L, B=11L, sampling_type="S", prop_feats_remove=0)) testthat::expect_error(createSubsamples(n=11.1, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0), "n == round(n) is not TRUE", fixed=TRUE) testthat::expect_error(createSubsamples(n=-20L, p=5L, B=11L, sampling_type="SS", prop_feats_remove=0), "n > 0 is not TRUE", fixed=TRUE) testthat::expect_error(createSubsamples(n=20L, p=5L, B=25.6, sampling_type="SS", prop_feats_remove=0), "length(subsamples) == B is not TRUE", fixed=TRUE) }) ## Test passed with 2 successes. ## Test passed with 16 successes. ## Test passed with 19 successes. Tests for getSubsamps(): testthat::test_that("getSubsamps works", { res <- getSubsamps(n=18L, B=21L, sampling_type="SS") testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 2*21) testthat::expect_true(all(lengths(res) == 18/2)) testthat::expect_equal(length(unique(res[[7]])), 18/2) set <- res[[3]] comp_set <- res[[3 + 21]] testthat::expect_equal(length(intersect(set, comp_set)), 0) testthat::expect_equal(length(union(set, comp_set)), length(c(set, comp_set))) testthat::expect_equal(18, length(c(set, comp_set))) }) ## Test passed with 7 successes. Tests for getSelMatrix(): testthat::test_that("getSelMatrix works", { set.seed(98623) x <- matrix(stats::rnorm(25*6), nrow=25, ncol=6) y <- stats::rnorm(25) subsamps_object <- createSubsamples(n=25, p=6, B=12, sampling_type="SS", prop_feats_remove=0) res <- getSelMatrix(x=x, y=y, lambda=0.01, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso) testthat::expect_true(is.matrix(res)) testthat::expect_equal(nrow(res), 2*12) testthat::expect_equal(ncol(res), 6) testthat::expect_true(all(res %in% c(0, 1))) testthat::expect_true(all(is.integer(res))) # Try a different fitfun testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } # Note that value of lambda doesn't matter res2 <- getSelMatrix(x=x, y=y, lambda="foo", B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=testFitfun) testthat::expect_true(is.matrix(res2)) testthat::expect_equal(nrow(res2), 2*12) testthat::expect_equal(ncol(res2), 6) testthat::expect_true(all(res2 %in% c(0, 1))) testthat::expect_true(all(is.integer(res2))) # With the per-subsample tryCatch (#155a), cssLoop's is.integer(subsample) # failure is caught and tagged, so the length(res_list) == nrow(res) check # (res_list length 1 vs 24 rows) now trips first. testthat::expect_error(getSelMatrix(x=x, y=y, lambda="0.02", B=12, sampling_type="SS", subsamps_object="subsamps_object", num_cores=1, fitfun=testFitfun), "length(res_list) == nrow(res) is not TRUE", fixed=TRUE) testthat::expect_error(getSelMatrix(x=x[1:8, ], y=y, lambda="foo", B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=testFitfun), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(getSelMatrix(x=x, y=y, lambda=-0.02, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) # Wrong B testthat::expect_error(getSelMatrix(x=x, y=y, lambda=0.02, B=37, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "length(res_list) == nrow(res) is not TRUE", fixed=TRUE) }) ## Test passed with 14 successes. A killed parallel worker makes parallel::mclapply() return NULL for that subsample. That NULL is distinct from a legitimate integer(0) (“selected nothing”) result, so getSelMatrix() must error rather than silently record a zero row (which would bias the selection proportions) (#104, L8): testthat::test_that("getSelMatrix detects a killed parallel worker (#104)", { set.seed(98623) x <- matrix(stats::rnorm(25*6), nrow=25, ncol=6) y <- stats::rnorm(25) subsamps_object <- createSubsamples(n=25, p=6, B=12, sampling_type="SS", prop_feats_remove=0) # Simulate a worker that was killed: mclapply returns a list containing NULL. testthat::local_mocked_bindings( mclapply = function(...) list(NULL), .package = "parallel") testthat::expect_error( getSelMatrix(x=x, y=y, lambda=0.01, B=12, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1, fitfun=cssLasso), "parallel worker failed") }) ## Test passed with 1 success. We test the num_cores > 1 robustness fixes (issue #155). First (#155a), a fitfun failure is reported against its true subsample index rather than a prescheduling-misattributed one. fitfunFailureMessage() reads the tagged index carried by the cssr_loop_error, ignoring the (fallback) loop index it is passed: testthat::test_that("fitfunFailureMessage reads the tagged subsample index (#155a)", { msg <- fitfunFailureMessage( structure(list(i=7L, msg="boom"), class="cssr_loop_error"), 999L) testthat::expect_true(grepl("subsample 7", msg, fixed=TRUE)) testthat::expect_true(grepl("boom", msg, fixed=TRUE)) testthat::expect_false(grepl("subsample 999", msg, fixed=TRUE)) }) ## Test passed with 3 successes. End-to-end (#155a), when a fitfun fails on exactly one subsample under num_cores = 2, getSelMatrix() must name that subsample – not the successful subsample 1 it shares a preschedule chunk with. (Needs real forking, so the parallel call is probed and the test is skipped where forking is unavailable.) testthat::test_that("a parallel fitfun failure reports the true subsample (#155a)", { B <- 7L K <- 5L # in 2..B: shares preschedule chunk 1 with the SUCCESSFUL subsample 1 n <- 25L p <- 6L set.seed(408) x <- matrix(stats::rnorm(n * p), nrow=n, ncol=p) x[1, 1] <- -999 # sentinel "poison" marker in row 1 y <- stats::rnorm(n) # floor(n/2) = 12 distinct row indices per subsample; ONLY subsample K holds row 1. half <- floor(n / 2) subsamps_object <- lapply(seq_len(2L * B), function(j) if(j == K) 1:half else 2:(half + 1L)) # fitfun stops iff its subsample contains the poison row (row 1), else selects. poison_fitfun <- function(X, y, lambda){ if(any(X[, 1] == -999)) stop("poison") else c(1L, 2L) } # Probe real forking; skip (rather than fail) where unavailable. forked <- tryCatch({ parallel::mclapply(1:2, function(i) i, mc.cores=2L) TRUE }, error=function(e) FALSE) if(!forked){ testthat::skip("parallel forking unavailable in this environment") } err <- tryCatch( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=2L, fitfun=poison_fitfun), error=function(e) conditionMessage(e)) testthat::expect_true(grepl("subsample 5", err, fixed=TRUE)) testthat::expect_false(grepl("subsample 1", err, fixed=TRUE)) }) ## Test passed with 2 successes. And (#155b), fitfun warnings emitted inside forked workers must surface in the parent – the same count and messages as a serial run, rather than being silently swallowed: testthat::test_that("fitfun warnings surface under num_cores > 1 (#155b)", { B <- 6L n <- 25L p <- 6L set.seed(511) x <- matrix(stats::rnorm(n * p), nrow=n, ncol=p) y <- stats::rnorm(n) subsamps_object <- createSubsamples(n=n, p=p, B=B, sampling_type="SS", prop_feats_remove=0) # One warning per fitfun call; returns a valid selection. warn_fitfun <- function(X, y, lambda){ warning("wfit"); c(1L, 2L) } serial_warns <- testthat::capture_warnings( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=1L, fitfun=warn_fitfun)) # one warning per subsample = 2*B testthat::expect_equal(sum(serial_warns == "wfit"), 2L * B) # Probe real forking; skip where unavailable. forked <- tryCatch({ parallel::mclapply(1:2, function(i) i, mc.cores=2L) TRUE }, error=function(e) FALSE) if(!forked){ testthat::skip("parallel forking unavailable in this environment") } par_warns <- testthat::capture_warnings( getSelMatrix(x=x, y=y, lambda=0.01, B=B, sampling_type="SS", subsamps_object=subsamps_object, num_cores=2L, fitfun=warn_fitfun)) # parallel no longer swallows them: same count AND same messages as serial. testthat::expect_equal(sum(par_warns == "wfit"), 2L * B) testthat::expect_identical(sort(par_warns), sort(serial_warns)) }) ## Test passed with 3 successes. Tests for cssLasso(): testthat::test_that("cssLasso works", { set.seed(24509) x <- matrix(stats::rnorm(15*4), nrow=15, ncol=4) y <- stats::rnorm(15) res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_true(is.integer(res)) testthat::expect_true(length(res) <= 4) testthat::expect_true(length(res) >= 0) # A no-duplicates assertion used to belong here, and #188 removed it rather # than leaving it in place looking like coverage. cssLasso() now ends in # sort(unique(unlist(pred))), so it de-duplicates its own return value and no # such assertion made here can fail for any input -- it would be a guardrail # blinded by the very change it appears to guard. The property still holds, # for a structural reason upstream: nonzeroCoef() builds each slot as which[x], # a logical subset of distinct column indices, so duplicates never arise. testthat::expect_true(all(res <= 4)) testthat::expect_true(all(res >= 1)) testthat::expect_error(cssLasso(X=x[1:13, ], y=y, lambda=0.01), "For method cssLasso, y must be a vector of length equal to nrow(X).", fixed=TRUE) testthat::expect_error(cssLasso(X=x, y=y, lambda=-0.01), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) }) ## Test passed with 7 successes. predict.glmnet(type = \"nonzero\") does not return a stable container across glmnet versions, so cssLasso() must not care which one it gets. For the scalar s used here, glmnet 4.x returns a data.frame on a non-empty selection and a list on an empty one; glmnet 5.0 always returns a list. That is a consequence of the general rule, not the rule itself – 4.x coerces to a data.frame whenever apply() could simplify, which for one s value means whenever anything was selected. The clusterLassoCore() blocks further below cover the no-s case, where the same rule produces two different data.frame layouts (#190). These blocks mock glmnet::predict.glmnet to hand cssLasso() each shape directly, which pins the contract on any machine regardless of which glmnet is installed – the point being that a test exercising only the installed version pins nothing about the other one. The first block is the regression test for #188 proper: it fails on the pre-fix source at stopifnot(is.data.frame(pred)). The other two are pins rather than red-green tests – they pass on the pre-fix source too, and exist to hold the empty-selection and 4.x contracts against this refactor. testthat::test_that("cssLasso handles glmnet 5.0's list return shape (#188)", { set.seed(3011) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # glmnet >= 5.0 always returns a list, one slot per s value. Deliberately # UNSORTED so the assertion also pins the sort(); an already-ordered fixture # would pass whether or not the sort survived. testthat::local_mocked_bindings( predict.glmnet = function(...) list(c(4L, 1L, 3L)), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_identical(res, c(1L, 3L, 4L)) testthat::expect_true(is.integer(res)) }) testthat::test_that("cssLasso still handles glmnet 4.x's data.frame return shape (#188)", { set.seed(3012) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # glmnet 4.x's shape for a scalar s on a non-empty selection. The fix must be # bidirectional, not a swap of one hard-coded container for another. testthat::local_mocked_bindings( predict.glmnet = function(...) data.frame(X1 = c(4L, 1L, 3L)), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=0.01) testthat::expect_identical(res, c(1L, 3L, 4L)) testthat::expect_true(is.integer(res)) }) testthat::test_that("cssLasso returns an empty selection under either glmnet shape (#188)", { set.seed(3013) x <- matrix(stats::rnorm(20*5), nrow=20, ncol=5) y <- stats::rnorm(20) # Both 4.x and 5.0 signal "nothing selected" as a list holding NULL, so # unlist() gives length 0. This is the contract the container-independent # guard replaced an is.null(pred[[1]]) test to preserve. testthat::local_mocked_bindings( predict.glmnet = function(...) list(NULL), .package = "glmnet") res <- cssLasso(X=x, y=y, lambda=1e6) testthat::expect_identical(res, integer(0)) testthat::expect_true(is.integer(res)) }) ## Test passed with 2 successes. ## Test passed with 2 successes. ## Test passed with 2 successes. The blocks that follow cover the anchored-grid rewrite of cssLasso() (#125), which replaced predict.glmnet(exact = TRUE)’s internal full-path refit with a second glmnet() fit over the short grid anchoredLambdaGrid() builds. They divide the work deliberately, and the division is the thing to understand before changing any of them: the first block pins the output against the reference the rewrite replaced and passes on the pre-change source too; the second is the red-green regression test, and pins routing rather than construction; the third is what actually enforces the grid construction; and the fourth covers the on-grid short-circuit, which is a correctness requirement rather than a speed one. The degenerate-path block and the snapLambdaToGrid() blocks further down carry their own narratives. testthat::test_that("cssLasso is byte-identical to the exact refit (#125)", { # WHAT THIS PINS, since #199 narrowed it: cssLasso() is identical to the exact # refit EXCEPT where that refit's own interpolation produces sub-ULP debris. # Since #199, cssLasso() predicts at the penalty glmnet returned rather than at # the one it was asked for, so where the two differ in their last bits it reads # a solved column and the reference reads a blend of two -- and the blend can # carry a coefficient around 1e-17 that the solved column does not. # test_that("cssLasso returns a solved column rather than a blend (#199)") # pins where that divergence occurs. All four fixtures below round-trip # exactly, which is why none of them diverges and why their assertions did not # move. An inexact round trip is NOT on its own enough to redden this block: # measured over fixtures satisfying this block's own two rules, the large # majority of the inexact ones stay green, because a blend has to leak a # feature the reference does not already carry before the selected sets can # differ. # # A PIN, NOT A RED-GREEN TEST -- like the second and third #188 blocks above, # it passes on the pre-change source, because before the rewrite cssLasso() # *was* this reference. The block that fails on the pre-change source is # test_that("cssLasso fits the anchored grid rather than refitting exactly # (#125)"). The block that enforces the grid construction is # test_that("anchoredLambdaGrid holds its invariants (#125)"): this pin stays # entirely green under every simplification of that construction anyone has # tried -- dropping the re-appended anchor, dropping the head anchor, keeping # the prefix through kt, dropping the interior filter, naive truncation, and # removing the shortening altogether -- each of which reddens only the # invariants block. A green run here is not licence to simplify the helper. # # IF THIS BLOCK REDDENS, rule out a local change first -- most likely to # cssLasso()'s on-grid branch predicate, which reddens this block directly, or # to snapLambdaToGrid(), whose tolerance decides which penalties cssLasso() # treats as an exact grid hit and so which of them can still diverge here. A # change to anchoredLambdaGrid() reddens it only rarely: every mutation of the # helper tried during review left this block green, which is why the invariants # block below exists and why a green run here is not licence to simplify the # helper. Only once both are excluded does it mean glmnet has # changed one of the two internals the bit-identity rests on -- lambda.interp()'s # lambda[1] - lambda[k] normaliser, or the round trip a user-supplied lambda # grid makes through the response scale. That distinction matters because in # the litr weave this failure prints no test name and no assertion, arriving # instead as the missing-'./cssr' red herring, so this comment is the whole # diagnosis a reader gets. # # The reference MUST be built with do.call: exact=TRUE re-evaluates the fit's # stored call through update(), and a call that stored the symbol `alpha` # throws "object 'alpha' not found". That is why the production code used to # build its fit that way, and this is now the one place that still exercises # the fact. pin <- function(X, y, L, alpha){ ref_fit <- do.call(glmnet::glmnet, list(x=X, y=y, family="gaussian", alpha=alpha)) # Two fixture rules, asserted rather than written down, because a rule # nothing checks rots the first time someone adds a fixture. (i) L must sit # at least 1e-14 relative away from every fitted penalty: closer than that, # lambda.interp()'s approx() emits "collapsing to unique 'x' values" -- on # the current, the anchored and the naive-truncation paths alike, so it is # pre-existing rather than introduced here -- and importing it would move # the suite's WARN 0 baseline. (ii) the reference must select more than one # feature: an L above lambda_max clears rule (i) by orders of magnitude and # selects nothing, which reduces the identity assertion to # identical(integer(0), integer(0)) and makes it pass for the naive # truncation this change exists to avoid, and indeed for any implementation # at all. More than one rather than at least one because the naive grid's # breaks concentrate in *which* of several features moves. testthat::expect_gt(min(abs(L - ref_fit$lambda)/L), 1e-14) ref <- as.integer(sort(unique(unlist(glmnet::predict.glmnet(ref_fit, type="nonzero", s=L, exact=TRUE, x=X, y=y))))) testthat::expect_gt(length(ref), 1L) testthat::expect_identical(cssLasso(X=X, y=y, lambda=if(alpha == 1) L else c(lambda=L, alpha=alpha)), ref) } # Exactly four fixtures, spanning the regimes that matter -- and ADDING MORE # WOULD BUY NOTHING, which is the part worth knowing before anyone tries. This # pin compares selected sets, via type="nonzero", while the property at stake # is bit-identity of the coefficients. Measured: naive truncation breaks # bit-identity on roughly 2% of off-grid penalties yet reproduced the # reference's selected set in every one of 600 comparisons. So the limit is # GRANULARITY, not sample size, and the enforcer is the invariants block. Four # fixtures pin the regimes; a fortieth would pin nothing further. # (1) An ordinary iid design. set.seed(5011) n <- 60 p <- 25 X_iid <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y_iid <- as.numeric(X_iid %*% c(rep(1.5, 3), rep(0, p - 3)) + stats::rnorm(n)) pin(X_iid, y_iid, 0.164396, 1) # (2) A strongly correlated design, built the way the bundled-alpha block # above builds one. set.seed(5012) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y_corr <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) pin(Z, y_corr, 0.355123, 1) # (3) n < p, the regime cssr itself targets. set.seed(5013) n <- 40 p <- 120 X_np <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y_np <- as.numeric(X_np %*% c(rep(1.5, 4), rep(0, p - 4)) + stats::rnorm(n)) pin(X_np, y_np, 0.420866, 1) # (4) alpha bundled into lambda at a value other than 1, so the elastic-net # route is pinned too. pin(Z, y_corr, 0.887808, 0.4) }) ## Test passed with 12 successes. The regression test proper. It captures how cssLasso() calls predict.glmnet() and asserts that the call is no longer an exact refit and that the object handed over is the anchored fit: testthat::test_that("cssLasso fits the anchored grid rather than refitting exactly (#125)", { set.seed(5014) n <- 80 p <- 40 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 5), rep(0, p - 5)) + stats::rnorm(n)) # Off-grid and mid-path, so the truncation is substantial. L <- 0.153994 fA <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) seen <- NULL testthat::local_mocked_bindings( predict.glmnet = function(object, ..., exact=FALSE){ seen <<- list(exact=exact, k=length(object$lambda)) return(list(NULL)) }, .package="glmnet") # list(NULL) is the "nothing selected" shape, so cssLasso()'s own container # handling runs to completion and returns integer(0); the assertions are about # the call it made, not the value it returned. invisible(cssLasso(X=X, y=y, lambda=L)) # WHAT THE SECOND ASSERTION PINS: routing -- that cssLasso() handed # predict.glmnet() the anchored fit and not the full default path. It does NOT # pin what the grid contains, and naming anchoredLambdaGrid() inside it makes # it look as though it does. Production and the assertion call the same # helper, so a wrong construction moves both sides together and leaves this # block green; every helper mutant named in # test_that("anchoredLambdaGrid holds its invariants (#125)") passes here. That # block is what catches those. # # The form is expect_identical against the helper's own length rather than # expect_lt(seen$k, length(fA$lambda)), which is red pre-change too but is # coupled to the interior-padding constant: raising n_interior far enough # would redden a test whose message points at the wrong thing, even though # n_interior is a speed knob that cannot change any result. testthat::expect_false(isTRUE(seen$exact)) testthat::expect_identical(seen$k, length(anchoredLambdaGrid(fA$lambda, L))) }) ## Test passed with 2 successes. The invariants of anchoredLambdaGrid() itself, which is the block that enforces the grid construction. It calls the helper directly rather than mocking it: mocking a cssr-internal binding does not work in the bare weave, and there is nothing to gain from it here anyway. testthat::test_that("anchoredLambdaGrid holds its invariants (#125)", { # THE THREE MUTANTS THIS BLOCK EXISTS TO CATCH, and the assertion family that # catches each -- all three are natural "simplifications" a future reader may # try, and none of them is caught by # test_that("cssLasso is byte-identical to the exact refit (#125)"): # # dropping the re-appended final anchor -> the last-element assertion # keeping the prefix through kt, not kt + 1 -> the prefix assertion # dropping the mid[mid < hi & mid > lo] filter -> the strictly-decreasing # and no-duplicates pair # # DO NOT claim this block catches a change to the interior *spacing* rule # (geometric to arithmetic). Nothing catches it and nothing should: the # coefficients at s depend only on the grid's two endpoints and the retained # prefix, so the spacing of the filler is a pure speed choice. # # THE ULP-SPACED FIXTURE AT THE BOTTOM IS MANDATORY, and it is the reason the # strictly-decreasing and no-duplicates pair is worth asserting at all. # Without it those two cannot fail: on every other fixture here the shipped # construction is well-formed by construction, and on the guard branch the # helper returns unique(c(keep, lo)), which makes a no-duplicates assertion a # guardrail blinded by its own input -- the same shape #188 removed from the # "cssLasso works" block above rather than leave it looking like coverage. # Every fixture below whose kept prefix already reaches the end of the # augmented grid takes that branch, and so does the n_interior = 0 one. On a # path whose entries are a few ULPs apart the pair becomes live, because that # is where dropping the filter lets an interior point land on an anchor. All # three of the fixture's parts are load-bearing: a fixed vector rather than a # random draw (with an unseeded draw the detection is a coin flip), an # interior s rather than one below the path or at 0 (those take the guard # branch), and n_interior at the production 5, passed explicitly here rather # than taken from the default. Measured, the detection threshold is 5 and not # 2: below it the interior points are too sparse to land on an anchor and the # pair goes blind again. # `shortens` pins THE POINT OF THE CHANGE, which the five invariants below do # not: g_full satisfies every one of them, because it IS the reference grid. # Measured -- replacing this helper's body with return(g_full), i.e. removing # the optimisation outright, left the whole suite byte-identical at # [ FAIL 0 | WARN 0 | SKIP 0 | PASS 4262 ] before this argument existed. The # routing block cannot cover the gap either: it compares the fitted grid's # length against a call to this same helper, so a helper that stopped # shortening would move both sides of that comparison together. Both # directions are pinned, because returning the FULL grid is the correct # answer on the guard branch and is worth asserting rather than tolerating. inv <- function(lambda_path, s, n_interior=5L, shortens){ g <- anchoredLambdaGrid(lambda_path, s, n_interior) g_full <- unique(rev(sort(c(s, lambda_path)))) k_full <- length(g_full) m <- min(k_full, sum(g_full >= s) + 1L) # First and last elements identical to the augmented grid's, which is what # lambda.interp()'s lambda[1] - lambda[k] normaliser reads. testthat::expect_identical(g[1], g_full[1]) testthat::expect_identical(g[length(g)], g_full[k_full]) # Well-formed as a glmnet lambda argument. testthat::expect_true(all(diff(g) < 0)) testthat::expect_identical(length(unique(g)), length(g)) # The prefix through one element past s is carried over untouched. testthat::expect_identical(g[1:m], g_full[1:m]) # And the grid is actually shorter than the one exact=TRUE would have refit # over -- or exactly it, on the guard branch, where there is nothing to drop. if(shortens){ testthat::expect_lt(length(g), k_full) } else{ testthat::expect_identical(length(g), k_full) } } # A synthetic decreasing path, in the geometric shape glmnet's default grid # has. No RNG and no fit: this block is about the construction, not about # glmnet. lp <- exp(seq(log(2), log(0.01), length.out=30)) inv(lp, 5, shortens=TRUE) # s above the largest penalty inv(lp, 0.001, shortens=FALSE) # s below the smallest: guard branch inv(lp, lp[9], shortens=TRUE) # s exactly on the path inv(lp, 0, shortens=FALSE) # s = 0: guard branch inv(lp, sqrt(lp[9]*lp[10]), shortens=TRUE) # mid-path, the production case inv(lp, sqrt(lp[9]*lp[10]), 0L, shortens=TRUE) # no interior padding inv(0.5, 0.1, shortens=FALSE) # length-1 path, s below it inv(0.5, 5, shortens=FALSE) # length-1 path, s above it inv(0.5, 0.5, shortens=FALSE) # length-1 path, s equal to it # The ULP-spaced path: eight distinct, strictly decreasing doubles a few # units in the last place apart, exercised at an on-grid s and at the # production n_interior. lp_ulp <- 1 + (8:1) * .Machine$double.eps inv(lp_ulp, lp_ulp[4], 5L, shortens=FALSE) }) ## Test passed with 60 successes. Finally the on-grid short-circuit, which exists to keep the exported direct-call route byte-identical rather than to save a fit: testthat::test_that("cssLasso short-circuits when lambda is already on the path (#125)", { set.seed(5011) n <- 60 p <- 25 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 3), rep(0, p - 3)) + stats::rnorm(n)) # do.call here is habit rather than necessity -- alpha is a literal, and this # block's s values are all ON the fitted grid, so predict.glmnet(exact=TRUE) # returns without ever reaching update(). The identity block's claim to be the # one place that still exercises the stored-call fact is therefore accurate. fA <- do.call(glmnet::glmnet, list(x=X, y=y, family="gaussian", alpha=1)) # Rank 1 is in the fixture set deliberately: when the short-circuit is # deleted, the resulting selected-set breaks concentrate at the top of the # path. on_grid <- fA$lambda[c(1, 12)] for(L in on_grid){ ref <- as.integer(sort(unique(unlist(glmnet::predict.glmnet(fA, type="nonzero", s=L, exact=TRUE, x=X, y=y))))) testthat::expect_identical(cssLasso(X=X, y=y, lambda=L), ref) } # The mock is installed here rather than at the top of the block because it # would otherwise replace the predict.glmnet() that computes the reference # above; local_mocked_bindings() takes effect from this line to the end of the # block. # # This assertion and the identity assertions above are BOTH live, and an # earlier revision of this comment claimed the identity ones were not. # Measured against a [ FAIL 0 | PASS 4262 ] control, deleting the short-circuit # reddens three of this block's assertions, the rank-1 identity comparison # among them -- which is precisely why the comment above puts rank 1 in the # fixture set, and the two statements contradicted each other until now. What # this assertion adds is a cause rather than a symptom: it names the fit handed # to predict.glmnet(), so with the short-circuit the default path arrives # untouched and without it a second, shorter fit does. Do not trim the rank-1 # fixture as redundant -- it is the only value-level detector for this route. seen <- NULL testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ seen <<- length(object$lambda) return(list(NULL)) }, .package="glmnet") for(L in on_grid){ invisible(cssLasso(X=X, y=y, lambda=L)) testthat::expect_identical(seen, length(fA$lambda)) } }) ## Test passed with 4 successes. anchoredLambdaGrid()’s guard branch has a reason that is easy to mistake for a hypothetical: a perfectly orthogonal design makes glmnet() return a $lambda of NaN followed by zeros, and the guard is what keeps log(0) out of the interior-point construction on such a path. The next block pins that end to end, and in particular pins the decision not to validate $lambda at runtime: a positivity check on it would turn this case from an empty selection into an error, on exactly the shape issue #157 was filed to stop crashing. testthat::test_that("cssLasso survives a degenerate lasso path (#125)", { # A design with max|X'y| EXACTLY zero -- paired +1/-1 integer rows, the #157 # construction. Not merely orthogonal and not numerically small: measured, an # orthonormal X with a generic y gives an ordinary path, and so does one with # max|X'y| at 1e-16. Only exact zero degenerates the path. y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1)) X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0), c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1)) storage.mode(X) <- "double" testthat::expect_identical(max(abs(crossprod(X, y))), 0) # The path really is degenerate. These two assertions are the upstream-drift # detector: if a future glmnet stops returning NaN-then-zeros here, they fail # and the comment in anchoredLambdaGrid() about this case needs re-deriving. lam <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1)$lambda testthat::expect_true(anyNA(lam)) testthat::expect_true(any(lam == 0, na.rm=TRUE)) # And cssLasso() returns an empty selection rather than erroring. This is the # assertion that holds the no-runtime-validation decision: adding # stopifnot(all(lasso_model$lambda > 0)) -- or all(is.finite(.)), which also # fails here -- reddens this line. Use lambda strictly above 0; at exactly 0 # this design raises a PRE-EXISTING interpolation error on both this branch # and origin/main, which is not what this block is about. testthat::expect_identical(cssLasso(X=X, y=y, lambda=0.01), integer(0)) }) ## Test passed with 4 successes. The three blocks below cover the penalty snap (#199) – cssLasso() predicting at the entry glmnet reported rather than at the penalty it asked for. They divide the work as deliberately as the #125 blocks do: the first is the red-green regression test, and is the one criterion 5 names – though the third reddens under the same mutation too, so a reader scoring it should expect two assertions to move rather than one; the second pins the helper’s arithmetic against hand-built vectors, and owns the tolerance; the third drives the real cssLasso() end to end and asserts that what comes back is a solved lasso column’s nonzero set rather than a blend of two. testthat::test_that("cssLasso predicts at the penalty glmnet fitted (#199)", { # THE RED-GREEN TEST FOR #199, and the one acceptance criterion 5 names. It is # not the only block that reddens under the mutation -- measured, this block's # wiring assertion and the end-to-end block's structural assertion both go red # and nothing else in the suite moves. The # mutation to score is "helper present, call site absent": reverting the # source hunks outright deletes snapLambdaToGrid(), so # test_that("snapLambdaToGrid holds its invariants (#199)") fails with "could # not find function", which is the symbol's absence speaking rather than an # assertion observing behaviour. Only a block that drives cssLasso() sees the # wiring. Measured under that mutation: this block's wiring assertion and # test_that("cssLasso returns a solved column rather than a blend (#199)")'s # structural assertion are the only two things in the suite that redden. # # THE SAME MOCK AND THE SAME FIRING CONDITION LIVE IN # test_that("cssLasso returns a solved column rather than a blend (#199)"). # The nudge fires on !is.null(list(...)$lambda), which is a claim about how # cssLasso() spells its second glmnet() call, so a refactor of that call # disarms BOTH blocks at once rather than one of them. Change either mock and # check the other. (The negative control below is what makes such a # disarming visible here rather than silent.) # # The blend is reached by MOCKING rather than by a live fixture, because # glmnet echoes this fixture's grid back verbatim on this machine, so an # unmocked wiring assertion would be green before the change here. Mocking an # external package's binding is safe in the bare weave; mocking a cssr # internal is not, which is why the invariants block calls the helper # directly instead. set.seed(5014) n <- 80 p <- 40 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 5), rep(0, p - 5)) + stats::rnorm(n)) # FIXTURE CONSTRAINT, asserted rather than written down: L must be OFF the # first fit's own grid, so the refit route runs and the nudge below can # apply at all. An on-grid L short-circuits, the second glmnet() call never # happens, and the wiring assertion then reads TRUE wired and unwired alike. L <- 0.153994 m0 <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) testthat::expect_identical(match(L, m0$lambda, 0L), 0L) real_glmnet <- glmnet::glmnet # captured BEFORE local_mocked_bindings(), which # rebinds inside glmnet's namespace: glmnet::, glmnet::: and getFromNamespace() # inside a mock all resolve to the MOCK and recurse until R aborts with # "evaluation nested too deeply". # Measured, all three. In the weave that error is thrown from test_that() at # top level and arrives as the missing-'./cssr' red herring. seen_grid <- NULL seen_s <- NULL testthat::local_mocked_bindings( glmnet = function(...){ f <- real_glmnet(...) # The nudge is what the response-scale round trip does to a supplied # penalty, made deterministic. It applies only to the SECOND fit, whose # reported $lambda is the vector cssLasso() now reads; the condition is a # claim about how cssLasso() spells that call, which is why the negative # control below is not optional. The mock must delegate rather than # fabricate a fit, because cssLasso() runs stopifnot(all.equal(class(...))) # on the first one. # # THE CONSTANT IS 2*eps AND IS BOUNDED ON BOTH SIDES. What is multiplied # is glmnet's ECHO of L, not L: writing u for one ULP of L and m for its # significand, fl((L - u)*(1 + eps)) == L exactly whenever m < 1.5, and # this fixture's L = 0.153994 has m = 1.2320. So on a platform whose echo # sits an ULP below this machine's, a 1*eps nudge lands back on L, the # negative control below is red on correct code, and the wiring assertion # goes green with the wiring removed. Measured over 6e5 enumerated # (magnitude, echo) pairs inside glmnet's round-trip bound: 1*eps # collapses in about one in six, 2*eps in none, and 3*eps never collapses # but reaches an offset of 4.286 eps*L, outside the helper's n_ulp = 4. # More is not safer here. if(!is.null(list(...)$lambda)) f$lambda <- f$lambda*(1 + 2*.Machine$double.eps) f }, predict.glmnet = function(object, ..., s){ seen_grid <<- object$lambda seen_s <<- s return(list(NULL)) }, .package="glmnet") # list(NULL) is the "nothing selected" shape, so cssLasso()'s container # handling runs to completion; the assertions are about the call it made. invisible(cssLasso(X=X, y=y, lambda=L)) # THE INSTRUMENT'S OWN NEGATIVE CONTROL, and it is not optional: it says the # requested penalty is absent from the grid cssLasso() predicted from -- by # the nudge, by glmnet's natural round trip, or both. Without it the block has # two measured ways of passing while checking nothing. An on-grid L # short-circuits past the nudge, and this then reads L's own index in the # first fit's path rather than 0; and a mock whose firing condition stopped # matching how cssLasso() spells its second call nudges nothing, which reads # 27 on this fixture. It is 0 only in the state this block exists to test. testthat::expect_identical(match(L, seen_grid, 0L), 0L) # THE WIRING ASSERTION: the penalty handed to predict.glmnet() is an element # of the grid predicted from, which is exactly what makes lambda.interp() # report an exact hit. FALSE without the call site in cssLasso(), TRUE with it. testthat::expect_gt(match(seen_s, seen_grid, 0L), 0L) }) ## Test passed with 3 successes. The helper’s own arithmetic, pinned directly against hand-built vectors: testthat::test_that("snapLambdaToGrid holds its invariants (#199)", { # THIS BLOCK PINS THE ARITHMETIC, NOT THE WIRING, and it cannot pin the # wiring: reverting #199's source hunks deletes the function it calls, so it # would fail with "could not find function". The block that discharges the # red-green obligation is # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). # # The scalar precondition. This assertion is its only cover: measured before # it existed, deleting stopifnot(length(s) == 1L) from the helper reddened # nothing at all, so the guard could have been weakened later in silence. With # it, that deletion records an ERROR rather than a failure -- the mismatched # expect_error() re-raises and aborts this block, taking the assertions below # it with it, so read the error column and not just the summary line's FAIL, # which aggregates both. fixed = TRUE is mandatory: the message contains ( and # ), so it does not match itself as a regex (grepl(m, m) is FALSE), and at # edition 2 a mismatch aborts the whole render behind gotcha 1's # missing-directory error. testthat::expect_error(snapLambdaToGrid(c(1, 0.5), c(1, 0.5)), "length(s) == 1L is not TRUE", fixed=TRUE) # # TWO MUTANTS DELIBERATELY HAVE NO ASSERTION HERE, so that the next reader # does not add one. Replacing the tolerance comparison's <= with < is # undetectable, but NOT because nothing reaches the boundary -- the s = 0 # fixture below sits exactly on it, since |g - s| and the relative tolerance # are both 0 there. It is undetectable because on that boundary both branches # return the same double, so no observable differs. And a very large n_ulp is # harmless on cssLasso()'s ordinary route, because anchoredLambdaGrid() has # put s in the grid and which.min() therefore picks s's own echo whatever the # tolerance admits. eps <- .Machine$double.eps # One ULP below a grid entry, one ULP above, and an exact hit. The offsets are # built as g*(1 +- eps) rather than typed as literals so the fixture states # the property: the result is 1 to 2 ULP of g at any magnitude and can never # be zero for a normal double, so it is inside n_ulp = 4 by construction # rather than by measurement. g <- c(1.0, 0.5) testthat::expect_identical(snapLambdaToGrid(g, 1.0*(1 + eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 1.0*(1 - eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 1.0), 1.0) testthat::expect_identical(snapLambdaToGrid(g, 0.5*(1 - eps)), 0.5) # THE ONLY FIXTURE THAT MAKES THE TOLERANCE'S * s SCALING LOAD-BEARING, and # its magnitude is the point of it. Measured: an absolute-tolerance mutant # (n_ulp*eps with the * s dropped) is INDISTINGUISHABLE from the correct # helper at magnitude 4, and first diverges at 6 -- on grid c(6, 3) the # correct helper returns 6 and the mutant returns 6.0000000000000018, and here # it returns 1000000.0000000002. Every other fixture in this block sits at # O(1), and cssLasso()'s penalty is on the response scale, so a user with a # larger response is exactly who the mutant silently stops snapping for. DO # NOT "simplify" this to a friendlier magnitude. testthat::expect_identical(snapLambdaToGrid(c(1e6, 5e5), 1e6*(1 + eps)), 1e6) # A penalty between two well-separated entries, ON BOTH SIDES. Both are needed # because dropping abs() from the tolerance comparison is a genuine one-sided # defect and only the below case catches it: measured on this grid, s = 0.7 # (nearest entry 0.5, below it) reddens that mutant while s = 0.8 (nearest # entry 1.0, above it) leaves it green. testthat::expect_identical(snapLambdaToGrid(g, 0.7), 0.7) testthat::expect_identical(snapLambdaToGrid(g, 0.8), 0.8) # A length-1 lambda_fitted, which has the same asymmetry: 0.9 is the case # that catches the dropped-abs() mutant. testthat::expect_identical(snapLambdaToGrid(0.5, 0.9), 0.9) testthat::expect_identical(snapLambdaToGrid(0.5, 0.1), 0.1) testthat::expect_identical(snapLambdaToGrid(0.5, 0.5*(1 + eps)), 0.5) # NaN mixed with numbers is the shape glmnet's FIRST fit returns on the # degenerate path test_that("cssLasso survives a degenerate lasso path # (#125)") drives, and which.min() simply ignores it. All-NaN and empty are # the two inputs that make which.min() return integer(0), where # if(logical(0)) would abort: they are what the length(j) == 1L clause is # for. NONE OF THE THREE IS REACHABLE THROUGH cssLasso() TODAY -- measured, # anchoredLambdaGrid() drops the NaN, so even on that degenerate design the # vector arriving here is c(0.01, 0) -- but the helper is stated to survive # them, so it must. testthat::expect_identical(snapLambdaToGrid(c(NaN, 1.0, 0.5), 1.0*(1 + eps)), 1.0) testthat::expect_identical(snapLambdaToGrid(c(NaN, NaN), 0.3), 0.3) testthat::expect_identical(snapLambdaToGrid(numeric(0), 0.3), 0.3) # s = 0 is permitted by checkCssLassoInputs(), and there the relative # tolerance collapses to exactly zero, so only an exact zero in lambda_fitted # can match. Both grids therefore return 0 and the pair cannot be told apart # by value -- one returns the grid's own zero and the other returns s. What it # pins is that neither path errors and neither drifts off zero. testthat::expect_identical(snapLambdaToGrid(c(1.0, 0.5, 0), 0), 0) testthat::expect_identical(snapLambdaToGrid(c(1.0, 0.5), 0), 0) }) ## Test passed with 16 successes. And the end-to-end effect: the coefficient vector cssLasso() reads back is a solved lasso path column, so its non-selected entries are exact zeros rather than a blend’s residue. testthat::test_that("cssLasso returns a solved column rather than a blend (#199)", { # WHAT THIS BLOCK DOES AND DOES NOT COVER, stated the way the #125 blocks # state their division of labour, because a future reader who trims something # on the strength of three green blocks is the failure mode. # # - j below is a DELIBERATE SECOND COPY of the argmin, hard-coded rather than # a call to snapLambdaToGrid(). That is why a production change to the # argmin -- which.max, a dropped abs(), an off-by-one -- moves the result # without moving the reference and is caught here. DO NOT "de-duplicate" it # into a helper call; doing so is exactly what blinds this block. # - It CANNOT see a tolerance that is too permissive, by construction: the # reference is the nonzero set of the column nearest L, which is what a # helper with no tolerance at all produces, so every mutant that widens the # tolerance moves both sides together. The invariants block owns tolerance. # - It does not rebuild the anchored grid, so it is not coupled to production # through anchoredLambdaGrid(). It IS blind to a change in which fit is # routed to predict.glmnet(), since it reads its reference off the very # object cssLasso() chose -- and that has independent cover: measured, # making cssLasso() never refit reddens # test_that("cssLasso is byte-identical to the exact refit (#125)"), # test_that("cssLasso fits the anchored grid rather than refitting exactly # (#125)"), test_that("cssLasso survives a degenerate lasso path (#125)") # and test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). # Four blocks, so do not trim one of them believing this block covers it. # - It shares its mock, and the mock's firing condition, with # test_that("cssLasso predicts at the penalty glmnet fitted (#199)"). That # condition is a claim about how cssLasso() spells its second glmnet() # call, so a refactor of that call disarms BOTH blocks at once. Change # either mock and check the other. # - The one residual coupling, named rather than denied: the assertion embeds # the same belief the helper embeds, that the right column is the argmin of # |grid - L|. If that belief were wrong, both would move together. That is # inherent to a structural assertion of this shape. set.seed(2019) n <- 40 p <- 30 X <- matrix(stats::rnorm(n*p), nrow=n, ncol=p) y <- as.numeric(X %*% c(rep(1.5, 4), rep(0, p - 4)) + stats::rnorm(n)) # Off the first fit's grid, so the refit route runs, and near the top of the # path, where a blend is most likely: lambda.interp() forms (lambda[1] - s) # over the normaliser (lambda[1] - lambda[k]), and the numerator's subtraction # absorbs more of an ULP-scale perturbation of s the further s sits below # lambda[1]. It is a gradient and NOT a threshold -- measured, blends occur # down to L/lambda[1] near 0.05 -- so this fixture is chosen to make the blend # reliable here, not because a lower one could not blend. L <- 1.6415147022263146 m0 <- glmnet::glmnet(x=X, y=y, family="gaussian", alpha=1) testthat::expect_identical(match(L, m0$lambda, 0L), 0L) real_glmnet <- glmnet::glmnet # captured BEFORE local_mocked_bindings() -- real_pred <- glmnet::predict.glmnet # `glmnet::` inside a mock reaches the MOCK seen_fit <- NULL testthat::local_mocked_bindings( glmnet = function(...){ f <- real_glmnet(...) if(!is.null(list(...)$lambda)) f$lambda <- f$lambda*(1 + 2*.Machine$double.eps) f }, predict.glmnet = function(object, ...){ seen_fit <<- object real_pred(object, ...) }, .package="glmnet") got <- cssLasso(X=X, y=y, lambda=L) # THE PERTURBATION IS SYNTHETIC ON PURPOSE. Driving the fixture's own natural # round trip would put a platform-dependent assertion inside a gating CI # matrix: fl(fl(s/ys)*ys) is exact for about 90% of random pairs and this # fixture is in the inexact 10%, so an ULP move in the response scale -- which # glmnet computes in Fortran, where -ffp-contract=fast permits FMA -- redraws # it with roughly a nine-in-ten chance of becoming exact. The constant is # 2*eps for the reason the routing block's comment gives. The cost, recorded # rather than hidden: no gating assertion anywhere exercises glmnet's natural # round trip. Note also that seen_fit is not an object glmnet ever produced -- # it carries a synthetic $lambda and a real $beta, and the assertion reads the # real half. # # The anti-vacuity guard, and it is about the fit cssLasso() actually # predicted from, which is why that fit is captured rather than rebuilt: the # requested penalty is absent from that grid, by the nudge, by the natural # round trip, or both. What the guard is FOR is the platform where neither # holds: there L would be in the grid, frac would be exactly 1, and the block # would return the same answer before and after the change, so the guard # reddens instead of passing vacuously. It cannot, however, detect the nudge # alone going away -- measured on this machine, with both nudges disarmed the # guard still reads 0 and the block still separates 1 3 4 from 1 4, because # this fixture's natural round trip is already inexact here. testthat::expect_identical(match(L, seen_fit$lambda, 0L), 0L) j <- which.min(abs(seen_fit$lambda - L)) # unname() IS LOAD-BEARING, NOT TIDINESS: seen_fit$beta is a dgCMatrix whose # rownames glmnet sets to V1 ... Vp, so which() returns a NAMED integer vector # while cssLasso() returns an unnamed one, and the assertion without it is red # on correct code at both editions -- reporting a names diff, whose first # reading is "the snap did not work". testthat::expect_identical(got, unname(which(seen_fit$beta[, j] != 0))) }) ## Test passed with 3 successes. Tests for getClusterSelMatrix(): testthat::test_that("getClusterSelMatrix works", { good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L, blue_clust=9L) B <- 14 p <- 9 res_entries <- as.integer(sample(c(0, 1), size=2*B*p, replace=TRUE)) good_res <- matrix(res_entries, nrow=2*B, ncol=p) res <- getClusterSelMatrix(good_clusters, good_res) testthat::expect_true(is.matrix(res)) testthat::expect_equal(nrow(res), 2*B) # 3 clusters testthat::expect_equal(ncol(res), 3) testthat::expect_identical(colnames(res), c("red_cluster", "green_cluster", "blue_clust")) testthat::expect_true(all(is.integer(res))) testthat::expect_true(all(res %in% c(0, 1))) # (#105, L12) Value-pin EVERY cluster column (not just cluster 2): each column # must equal the "at least one member of that cluster was selected" indicator. # This pins the full feat2clus mapping/ordering that the #57 rowsum refactor # relies on, including the singleton cluster (drop=FALSE keeps it a matrix). for(j in seq_along(good_clusters)){ testthat::expect_equal(res[, j], as.integer(rowSums(good_res[, good_clusters[[j]], drop=FALSE]) > 0)) } # Single-cluster case (#57): t(clust_counts > 0L) collapses to one column res1 <- getClusterSelMatrix(list(only = 1L:9L), good_res) testthat::expect_equal(ncol(res1), 1) testthat::expect_true(all(is.integer(res1))) # Not all features in a cluster bad_clusters <- list(red_cluster=1L:5L, green_cluster=6L:7L, blue_clust=9L) testthat::expect_error(getClusterSelMatrix(bad_clusters, good_res), "length(all_clustered_feats) == p is not TRUE", fixed=TRUE) bad_res_entries <- as.integer(sample(c(0, 1, 2), size=2*B*p, replace=TRUE)) bad_res <- matrix(bad_res_entries, nrow=2*B, ncol=p) testthat::expect_error(getClusterSelMatrix(good_clusters, bad_res), "all(res %in% c(0, 1)) is not TRUE", fixed=TRUE) }) ## Test passed with 13 successes. Finally, tests for css() itself! testthat::test_that("css works", { set.seed(8712) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:5L, green_cluster=6L:8L, c4=10:11) res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, fitfun = cssLasso, sampling_type = "SS", B = 13, prop_feats_remove = 0, train_inds = integer(), num_cores = 1L) # Basic output testthat::expect_true(is.list(res)) testthat::expect_identical(class(res), "cssr") testthat::expect_identical(names(res), c("feat_sel_mat", "clus_sel_mat", "X", "y", "clusters", "train_inds")) # feat_sel mat testthat::expect_true(is.integer(res$feat_sel_mat)) testthat::expect_true(is.matrix(res$feat_sel_mat)) testthat::expect_true(all(res$feat_sel_mat %in% c(0, 1))) testthat::expect_equal(ncol(res$feat_sel_mat), 11) testthat::expect_null(colnames(res$feat_sel_mat)) # clus_sel_mat testthat::expect_true(is.integer(res$clus_sel_mat)) testthat::expect_true(is.matrix(res$clus_sel_mat)) testthat::expect_true(all(res$clus_sel_mat %in% c(0, 1))) # 4 clusters testthat::expect_equal(ncol(res$clus_sel_mat), 4) testthat::expect_identical(colnames(res$clus_sel_mat), names(res$clusters)) testthat::expect_equal(length(colnames(res$clus_sel_mat)), 4) testthat::expect_equal(length(unique(colnames(res$clus_sel_mat))), 4) testthat::expect_true(all(!is.na(colnames(res$clus_sel_mat)))) testthat::expect_true(all(!is.null(colnames(res$clus_sel_mat)))) # X testthat::expect_true(is.matrix(res$X)) testthat::expect_true(all(!is.na(res$X))) testthat::expect_true(is.numeric(res$X)) testthat::expect_equal(ncol(res$X), 11) testthat::expect_equal(nrow(res$X), 15) # y testthat::expect_true(is.numeric(res$y)) testthat::expect_equal(length(res$y), 15) # clusters testthat::expect_true(is.list(res$clusters)) testthat::expect_equal(length(res$clusters), length(names(res$clusters))) testthat::expect_equal(length(res$clusters), length(unique(names(res$clusters)))) testthat::expect_true(all(!is.na(names(res$clusters)))) testthat::expect_true(all(!is.null(names(res$clusters)))) clust_feats <- integer() for(i in 1:length(res$clusters)){ clust_feats <- c(clust_feats, res$clusters[[i]]) } testthat::expect_equal(length(clust_feats), length(unique(clust_feats))) testthat::expect_equal(length(clust_feats), length(intersect(clust_feats, 1:11))) # train_inds testthat::expect_identical(res$train_inds, integer()) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars res_fitfun <- css(X=X_df, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10) testthat::expect_identical(class(res_fitfun), "cssr") # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) res_fitfun <- css(X=df2, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10) testthat::expect_identical(class(res_fitfun), "cssr") # Should get error if I try to use clusters in this data.frame that contains # factors with more than two levels testthat::expect_error(css(X=df2, y=stats::rnorm(nrow(X_df)), lambda=0.01, B = 10, clusters=1:3), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] res_names <- css(X=x2, y=y, lambda=0.01, clusters=good_clusters, B = 13) testthat::expect_identical(class(res_names), "cssr") testthat::expect_identical(colnames(x2), colnames(res_names$X)) testthat::expect_identical(colnames(x2), colnames(res_names$feat_sel_mat)) # Custom fitfun with nonsense lambda (which will be ignored by fitfun, and # shouldn't throw any error, because the acceptable input for lambda should be # enforced only by fitfun) testFitfun <- function(X, y, lambda){ p <- ncol(X) stopifnot(p >= 2) # Choose p/2 features randomly selected <- sample.int(p, size=floor(p/2)) return(selected) } res_fitfun <- css(X=x, y=y, lambda=c("foo", as.character(NA), "bar"), clusters=1:3, B = 10, fitfun=testFitfun) testthat::expect_identical(class(res_fitfun), "cssr") # Bad lambda testthat::expect_error(css(X=x, y=y, lambda=-0.01, B = 10), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(css(X=x, y=y, lambda="foo", B = 10), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) # Single cluster res_sing_clust <- css(X=x, y=y, lambda=0.01, clusters=1:3, B = 10) testthat::expect_identical(class(res_sing_clust), "cssr") testthat::expect_equal(length(res_sing_clust$clusters), 11 - 3 + 1) testthat::expect_true(length(unique(names(res_sing_clust$clusters))) == 11 - 3 + 1) testthat::expect_true(all(!is.na(names(res_sing_clust$clusters)))) testthat::expect_true(all(!is.null(names(res_sing_clust$clusters)))) # No cluster testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10)), "cssr") # All clusters named testthat::expect_identical(class(css(X=x, y=y, clusters=list("a"=1:5, "b"=6:10, "c"=11), lambda=0.01, B=10)), "cssr") # Other sampling types testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type="MB"), "sampling_type MB is not yet supported (and isn't recommended anyway)", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type="S")) testthat::expect_error(css(X=x, y=y, lambda=1, sampling_type=1), "is.character(sampling_type) is not TRUE", fixed=TRUE) # B testthat::expect_warning(css(X=x, y=y, lambda=1, B=5), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_error(css(X=x, y=y, lambda=1, B=list(10)), "is.numeric(B) | is.integer(B) is not TRUE", fixed=TRUE) # Clusters testthat::expect_error(css(X=x, y=y, lambda=1, clusters="red"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) # prop_feats_remove testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10, prop_feats_remove=0.3)), "cssr") # Weirdly high, but still valid, value of prop_feats_remove testthat::expect_identical(class(css(X=x, y=y, lambda=0.01, B = 10, prop_feats_remove=0.9999999999)), "cssr") # Use train_inds argument res_train <- css(X=x, y=y, lambda=0.01, B = 10, train_inds=11:15) testthat::expect_equal(res_train$train_inds, 11:15) }) testthat::test_that("duplicate clusters are removed to match the docs (#156)", { set.seed(9156) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) # (i) Unnamed duplicate cluster: css returns the same result as the # deduplicated input (css is stochastic, so seed both calls identically). set.seed(41) res_dup <- css(X=x, y=y, lambda=0.01, clusters=list(1:2, 1:2), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) set.seed(41) res_dedup <- css(X=x, y=y, lambda=0.01, clusters=list(1:2), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) testthat::expect_identical(res_dup, res_dedup) # (ii) First name wins, DIRECT helper path (checkFormatClustersInput, finding # 2): the length check now runs before the removal, so a named duplicate keeps # the first occurrence and its name. testthat::expect_identical( checkFormatClustersInput(list(a=2:3, b=2:3), p=10, clust_names=c("a", "b"), get_prototypes=FALSE, x=NA, y=NA, R=NA), list(a=2:3)) # (ii) First name wins, END-TO-END css path (checkCssInputs, finding 3): a # named duplicate runs without error and keeps the first occurrence's name. res_named <- css(X=x, y=y, lambda=0.01, clusters=list(myclust=2:3, dup=2:3), fitfun=cssLasso, sampling_type="SS", B=13, prop_feats_remove=0, train_inds=integer(), num_cores=1L) testthat::expect_true("myclust" %in% names(res_named$clusters)) testthat::expect_false("dup" %in% names(res_named$clusters)) # (iii) cssSelect and cssPredict route through css -> checkCssInputs, so they # inherit the fix: a named duplicate cluster runs without error. # # cssPredict() reports a max_num_clusts tie on this fixture on this machine, # because #199's penalty snap changed which features cssLasso() returns here # and dropped the modal cluster's selection proportion into a tie. The tie is # not asserted: whether it occurs depends on the estimated model size, and so # on glmnet's lasso path rather than on cssr. The warning itself keeps # deterministic coverage in "checkSelectedClusters works" and in # test_that("plot.cssr surfaces the tie-breach warning (#159c)"), and muffling # this one message by its text leaves every other warning in the block visible # (#186, #199). # # BOTH calls are wrapped although only cssPredict() ties today, because which # of them ties follows from that same lasso path, so a one-call muffle would # redden on a platform whose path differs slightly. The assertions below are # untouched -- they are about well-formedness of the returns, which the tie is # orthogonal to. sel <- withCallingHandlers( cssSelect(X=x, y=y, clusters=list(myclust=2:3, dup=2:3)), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) testthat::expect_identical(names(sel), c("selected_clusts", "selected_feats", "weights")) test_x <- matrix(stats::rnorm(5*11), nrow=5, ncol=11) preds <- withCallingHandlers( cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters=list(myclust=2:3, dup=2:3)), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) testthat::expect_true(is.numeric(preds)) testthat::expect_equal(length(preds), 5) }) testthat::test_that("css errors on an X containing NA (#74)", { set.seed(8642) X <- matrix(stats::rnorm(20 * 4), nrow = 20, ncol = 4) X[3, 2] <- NA y <- stats::rnorm(20) testthat::expect_error( css(X = X, y = y, lambda = 0.01), "must not contain missing", fixed = TRUE) }) ## Test passed with 57 successes. ## Test passed with 7 successes. ## Test passed with 1 success. The fitfun extension point accepts any function whose arguments are exactly X, y, and lambda – in any order, with or without defaults – because cssLoop calls fitfun by keyword (do.call(fitfun, list(X=..., y=..., lambda=...))). A wrong or extra argument set is rejected with a message listing the arguments actually detected (issue #154). testthat::test_that("css accepts any (X, y, lambda) fitfun signature and rejects wrong args (#154)", { set.seed(1) x <- matrix(stats::rnorm(60), 20, 3) y <- stats::rnorm(20) # (a) A default on lambda is accepted (rejected on the base by identical()). f_default <- function(X, y, lambda = 0.1) cssLasso(X, y, lambda) res_def <- css(x, y, lambda = 0.01, fitfun = f_default, B = 10) testthat::expect_identical(class(res_def), "cssr") # (b) Reordered args are accepted AND produce identical results # (cssLoop calls fitfun by keyword, so order is irrelevant). f_reordered <- function(y, X, lambda) cssLasso(X, y, lambda) set.seed(7); res_re <- css(x, y, lambda = 0.01, fitfun = f_reordered, B = 10) set.seed(7); res_ord <- css(x, y, lambda = 0.01, fitfun = cssLasso, B = 10) testthat::expect_equal(res_re$feat_sel_mat, res_ord$feat_sel_mat) # (c) A wrong argument set is rejected, with the message listing the ACTUAL args. testthat::expect_error( css(x, y, lambda = 0.01, fitfun = function(X, y, z) 1L, B = 5), "must accept exactly the arguments X, y, and lambda (in any order, with or without defaults). Detected arguments to fitfun: X, y, z", fixed = TRUE) # (d) Extra args are rejected, with the new "exactly" wording. testthat::expect_error( css(x, y, lambda = 0.01, fitfun = function(X, y, lambda, extra) 1L, B = 5), "must accept exactly the arguments", fixed = TRUE) }) ## Test passed with 4 successes. We also confirm the parallel feature-selection loop’s RNG is isolated per subsample (issue #12): cssLoop seeds the RNG immediately before fitfun, so a stochastic fitfun is reproducible and identical whether run serially or in parallel, given a seed set before css(). (The parallel checks require real forking, so they are guarded and skipped where forking is unavailable – Windows, CRAN, or a fully-loaded machine.) testthat::test_that("cssLoop seeds fitfun reproducibly; css parallel RNG is isolated (#12)", { set.seed(99) x_rng <- matrix(stats::rnorm(40 * 8), nrow=40, ncol=8) y_rng <- stats::rnorm(40) # A stochastic fitfun: randomly selects 2 features (uses the RNG), so its # output depends on the seed in effect when it runs. rfit <- function(X, y, lambda){ sort(sample.int(ncol(X), 2)) } sub <- sort(sample.int(40L, 20L)) # cssLoop's seed argument makes a stochastic fitfun reproducible: the same # seed gives the same selection. (On main, cssLoop has no seed argument, so # this behavior does not exist there.) This needs no parallelism. r1 <- cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=123L) r2 <- cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=123L) testthat::expect_identical(r1, r2) # ...and the seed genuinely drives the (stochastic) selection -- different # seeds give more than one distinct result (so the check above is not vacuous). outs <- lapply(1:8, function(s) cssLoop(input=sub, x=x_rng, y=y_rng, lambda=0.1, fitfun=rfit, seed=s)) testthat::expect_true(length(unique(outs)) > 1) # End-to-end, serial css is reproducible across re-runs. set.seed(1) d1 <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=1L)$feat_sel_mat set.seed(1) d2 <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=1L)$feat_sel_mat testthat::expect_identical(d1, d2) # Parallel checks need real forking; run the parallel css calls defensively # and skip (rather than fail) when forking is unavailable -- Windows, CRAN, or # a fully-loaded machine. A genuine reproducibility regression would still # surface as a failed expectation below, not a skip. par_runs <- tryCatch({ set.seed(1) a <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=2L)$feat_sel_mat set.seed(1) b <- css(x_rng, y_rng, lambda=0.1, fitfun=rfit, B=10L, num_cores=2L)$feat_sel_mat list(a=a, b=b) }, error=function(e) NULL) if(is.null(par_runs)){ testthat::skip("parallel forking unavailable in this environment") } testthat::expect_identical(par_runs$a, par_runs$b) # parallel reproducible testthat::expect_identical(par_runs$a, d1) # serial == parallel }) ## Test passed with 5 successes. We test the remaining num_cores robustness fixes (issue #155). parallel::detectCores() returns NA when the core count is indeterminable; that must not brick css() (#155c). We mock it and confirm the default num_cores = 1 still runs: testthat::test_that("detectCores() = NA does not brick css (#155c)", { set.seed(72) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings( detectCores = function(...) NA_integer_, .package = "parallel") res <- css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 1L) testthat::expect_s3_class(res, "cssr") }) ## Test passed with 1 success. …but when the core count IS known, the upper-bound guard must still fire, so an over-large num_cores is still rejected (#155c): testthat::test_that("num_cores beyond a known core count still errors (#155c)", { set.seed(72) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings( detectCores = function(...) 2L, .package = "parallel") testthat::expect_error( css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 5L), "num_cores <= n_cores_avail is not TRUE", fixed = TRUE) }) ## Test passed with 1 success. Finally (#155d), on Windows – where parallel::mclapply cannot fork – num_cores > 1 must downgrade to serial with a warning rather than hard-error. We mock the platform check so the branch is exercised off-Windows (it runs serially, so no real forking is needed): testthat::test_that("num_cores > 1 on Windows warns and runs serially (#155d)", { # Mocking a package-internal function needs a package context: local_mocked_bindings # resolves the package via testthat::testing_package(), which is set under # devtools::test and R CMD check but is empty during the bare litr weave (the cssr # functions live in the knit global env with no namespace to mock). Skip there; the # Windows branch is still exercised under devtools::test / R CMD check. if(testthat::testing_package() == ""){ testthat::skip("runningOnWindows mock needs a package context (unavailable during the litr weave)") } set.seed(84) data <- genClusteredData(n = 50, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) testthat::local_mocked_bindings(runningOnWindows = function() TRUE) testthat::expect_warning( res <- css(X = data$X, y = data$y, lambda = 0.01, B = 10, num_cores = 2L), "not supported on Windows", fixed = TRUE) testthat::expect_s3_class(res, "cssr") }) ## -- Skip: num_cores > 1 on Windows warns and runs serially (#155d) -------------- ## Reason: runningOnWindows mock needs a package context (unavailable during the litr weave) We test the highly-discrete-response diagnostic (issue #131): the @noRd helper discreteYAbortProb() that estimates the abort probability, and the up-front css() warning it drives (which fires only for the default cssLasso, and only when the estimated probability exceeds 1%). testthat::test_that("discreteYAbortProb estimates the constant-subsample probability (#131)", { # Continuous y: every value is distinct, so no size-floor(n/2) subsample can # be constant. The aggregate underflows to exactly 0 -- assert the inequality, # NOT expect_equal to a tiny value. set.seed(131) y_cont <- stats::rnorm(100) testthat::expect_true(discreteYAbortProb(y_cont, 50L, "SS") < 1e-6) # Balanced binary at n = 100: each value's count (50) equals m = 50, so # p_const = 2 * C(50,50)/C(100,50) ~ 2e-29 and the aggregate underflows to 0. # This is the KEY false positive that the naive max(table(y)) >= floor(n/2) # trigger gets wrong (there count == m would fire). y_bin <- rep(0:1, each = 50) testthat::expect_true(discreteYAbortProb(y_bin, 50L, "SS") < 1e-6) # Skewed y (95/5): 0 is a strong majority (count 95 >> m = 50), so some # subsample is very likely all-zeros (~94% at B = 50, SS). y_skew <- c(rep(0, 95), rep(1, 5)) testthat::expect_true(discreteYAbortProb(y_skew, 50L, "SS") > 0.5) # Fully constant y: every subsample is constant -> probability exactly 1. testthat::expect_equal(discreteYAbortProb(rep(0, 100), 50L, "SS"), 1) # Monotone in n_sub: "SS" draws 2*B subsamples, a non-"SS" string draws B, so # the SS probability is at least the B-count probability for the same y. (Pure # helper call exercising the n_sub branch; not a css() run.) testthat::expect_true( discreteYAbortProb(y_skew, 50L, "SS") >= discreteYAbortProb(y_skew, 50L, "MB")) }) testthat::test_that("css() warns up front on a highly discrete y for the default cssLasso (#131)", { set.seed(2718) n <- 40L x_disc <- matrix(stats::rnorm(n * 6), nrow = n, ncol = 6) # 0 is a strong majority (count 38 >> floor(40/2) = 20), so the estimated # abort probability is ~99% -- well over the 1% threshold. y has 3 unique # values, so it passes input checks and reaches the warning. y_disc <- c(rep(0, 38), 1, 2) # (a) discrete y + default cssLasso -> the up-front warning fires. Such a run # also aborts later in the loop (a constant-y subsample), so wrap the call in # try(): the warning is computed before any subsampling/RNG and fires either # way (B = 10L so the small-B checkB warning does not also fire). testthat::expect_warning( try(css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L), silent = TRUE), "highly discrete", fixed = TRUE) # The warning message reports a plausible percentage and names cssLasso. disc_warns <- testthat::capture_warnings( try(css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L), silent = TRUE)) disc_msg <- disc_warns[grepl("highly discrete", disc_warns, fixed = TRUE)] testthat::expect_length(disc_msg, 1L) testthat::expect_match(disc_msg, "%", fixed = TRUE) testthat::expect_match(disc_msg, "cssLasso", fixed = TRUE) # (b) continuous y -> no warning at all (a clean, complete run). set.seed(2719) x_cont <- matrix(stats::rnorm(n * 6), nrow = n, ncol = 6) testthat::expect_no_warning( css(X = x_cont, y = stats::rnorm(n), lambda = 0.01, B = 10L)) # (c) balanced binary at n = 100 -> NO "highly discrete" warning (the KEY # false-positive guard). At small n balanced binary can legitimately warn, so # keep n large. Capture all warnings and assert none match. set.seed(2720) x_bin <- matrix(stats::rnorm(100 * 6), nrow = 100, ncol = 6) y_bin <- rep(0:1, each = 50) bin_warns <- testthat::capture_warnings( css(X = x_bin, y = y_bin, lambda = 0.01, B = 10L)) testthat::expect_false(any(grepl("highly discrete", bin_warns, fixed = TRUE))) # (d) custom fitfun with the SAME discrete y -> NO warning (proves the # identical(fitfun, cssLasso) gate). The stub ignores y (so it tolerates a # constant-y subsample) and returns a fixed, valid selected set. tol_fitfun <- function(X, y, lambda){ c(1L, 2L) } testthat::expect_no_warning( css(X = x_disc, y = y_disc, lambda = 0.01, B = 10L, fitfun = tol_fitfun)) # (e) non-finite numeric y (majority Inf) + default cssLasso -> NO "highly # discrete" warning (proves the all(is.finite(sel_y)) guard). Without the # guard, table() would miscount the 38 Inf cells as a dominating value and # warn (~100%); with it, the diagnostic is skipped and cssLasso instead aborts # on the non-finite value (checkCssLassoInputs). Every size-floor(40/2) = 20 # subsample must include an Inf (only 2 finite cells), so the abort is # deterministic; wrap the warning-capture call in try(). y_nonfin <- c(rep(Inf, 38), 0, 1) nonfin_warns <- testthat::capture_warnings( try(css(X = x_disc, y = y_nonfin, lambda = 0.01, B = 10L), silent = TRUE)) testthat::expect_false(any(grepl("highly discrete", nonfin_warns, fixed = TRUE))) # ...and cssLasso still rejects the non-finite y (no warning to suppress now). testthat::expect_error( css(X = x_disc, y = y_nonfin, lambda = 0.01, B = 10L), "non-finite", fixed = TRUE) }) ## Test passed with 5 successes. ## Test passed with 9 successes. "],["tests-for-selection-and-prediction-functions.html", "9 Tests for selection and prediction functions", " 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)) }) testthat::test_that("getSelectedClusters returns the whole tied set when raising the threshold would empty it (#203)", { # The max loop can leave more than one way, and this block pins the way # nothing else detects. Exit A, `if(thresh > B) break`, fires when the tied # clusters sit TOGETHER at count B -- selection proportion exactly 1.0 -- # which is what "plot.cssr surfaces the tie-breach warning (#159c)" reaches. # The loop can also end on its own `while` condition, having succeeded: that # is what "getSelectedClusters max_num_clusts handles proportion-1.0 ties # (#42)" does, because its c1 at count B and c2 at count B - 1 are NOT tied, # so c2 drops out and the condition goes false before either break runs. # Exit B, the `else { break }` arm of `any(counts >= thresh)`, fires when the # clusters tie at any count BELOW B: the threshold steps past the tied count, # nothing meets it, and the loop breaks rather than emptying the selection. # Exit B is the branch a removal at the per-subsample fitting level reaches, # because a removal LOWERS a selection proportion rather than raising it to # 1.0. # # Fixture: three clusters, each selected on 3 of B = 10 subsamples, so all # three tie at count 3. thresh climbs 1 -> 2 -> 3, still selecting all three # each time, then 4, where any(counts >= 4) is FALSE and the else fires. # min_num_clusts = 1 because getSelectedClusters() has no default for it and # NA errors in the min loop's while condition. The weighting is NOT # load-bearing here: both loops run before any weight is computed. # # What makes this block about Exit B is the fixture reaching it, not the # warning: checkSelectedClusters() runs after both exits and renders the # identical string for each, so the literal cannot tell them apart. The three # assertions pin three different properties of the outcome -- that MORE than # max_num_clusts comes back, that it is the WHOLE tied set, and that the # breach is announced. Keep all three. B <- 10 clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L) props <- c(0.3, 0.3, 0.3) 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") testthat::expect_warning( res <- getSelectedClusters(obj, weighting = "simple_avg", cutoff = 0, min_num_clusts = 1, max_num_clusts = 1), "Returning more than max_num_clusts = 1 clusters", fixed = TRUE) # Strictly more than max_num_clusts comes back ... testthat::expect_gt(length(res$selected_clusts), 1) # ... and it is the WHOLE tied set, so a future rule returning only some of # the tied clusters fails here. expect_identical on names(), never # all(names(...) %in% ...): names() is NULL on an unnamed vector and # all(NULL %in% anything) is TRUE, so the %in% form would pass on an empty # return while reading as the strongest assertion in the block. testthat::expect_identical(names(res$selected_clusts), c("c1", "c2", "c3")) }) testthat::test_that("getSelectedClusters overshoots min_num_clusts on a whole-count tie, silently (#203)", { # The min loop lowers thresh by a WHOLE count, so one decrement admits every # cluster sitting at that count at once and the function can return strictly # MORE than min_num_clusts. Nothing warns: checkSelectedClusters() has a # branch for n_sel_clusts < min_num_clusts and none for the overshoot. # # Fixture: one cluster at count 8 and three tied at count 3, B = 10, with # cutoff = 0.8 so the initial threshold of 8 selects c1 alone. # min_num_clusts = 2 then decrements thresh down to 3, where the three tied # clusters are admitted together and four clusters come back for a minimum of # two. # # max_num_clusts = NA is LOAD-BEARING, not "unset": the max loop is wrapped in # if(!is.na(max_num_clusts)), so NA skips it entirely. It runs after the min # loop and undoes the overshoot, which the counter-case at the end of this # block pins. B <- 10 clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L, c4 = 4L) props <- c(0.8, 0.3, 0.3, 0.3) 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", "c4") feat_sel_mat <- clus_sel_mat colnames(feat_sel_mat) <- c("f1", "f2", "f3", "f4") obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat, clusters = clusters), class = "cssr") # capture_warnings() rather than a bare expect_silent() or a nested # expect_warning(): the woven chunks run at testthat edition 2, where an # expect_warning() consumes every warning, and this collector behaves # identically at both editions. overshoot_warns <- testthat::capture_warnings( res <- getSelectedClusters(obj, weighting = "simple_avg", cutoff = 0.8, min_num_clusts = 2, max_num_clusts = NA)) testthat::expect_gt(length(res$selected_clusts), 2) testthat::expect_identical(names(res$selected_clusts), c("c1", "c2", "c3", "c4")) # The silence is the property under question, so it is asserted rather than # assumed. #206 asks whether that silence is intended -- checkSelectedClusters() # warns on the min_num_clusts UNDERshoot and says nothing on the overshoot. # This assertion is what makes resolving #206 the other way a visible change # rather than a silent one, which is the point of pinning it while the # question is open. testthat::expect_length(overshoot_warns, 0) # Counter-case, and the reason max_num_clusts = NA above is load-bearing: with # a finite max_num_clusts the max loop runs after the min loop and undoes the # overshoot, returning FEWER than min_num_clusts and raising the opposite # warning. testthat::expect_warning( res_capped <- getSelectedClusters(obj, weighting = "simple_avg", cutoff = 0.8, min_num_clusts = 2, max_num_clusts = 3), "Returning fewer than min_num_clusts = 2 clusters", fixed = TRUE) testthat::expect_identical(names(res_capped$selected_clusts), "c1") }) ## Test passed with 60 successes. ## Test passed with 2 successes. ## Test passed with 6 successes. ## Test passed with 4 successes. ## Test passed with 3 successes. ## Test passed with 5 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 # checkGetCssPredsInputs() validates testX and trainX separately, and both # are unnamed here while the css X was named, so the warning fires once per # matrix. Collect rather than nesting two expect_warning() calls: the woven # chunks run at testthat edition 2 (no DESCRIPTION at the repo root), where # expect_warning() consumes every warning and a nested pair fails. Asserting # the length also turns an unexpected third warning into a failure (#186). # Keep both assertions: all(grepl(...)) is vacuously TRUE on an empty # vector, so expect_length() is what makes the pair non-blind. name_warns <- testthat::capture_warnings( 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_length(name_warns, 2) testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.", name_warns, 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))) }) ## Test passed with 126 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 # As at the checkGetCssPredsInputs site: testX and trainX are both unnamed, # so the warning fires once per matrix. Collected rather than nested for the # same edition-2 reason, and both assertions kept for the same reason (#186). name_warns <- testthat::capture_warnings( getCssPreds(css_res_named, testX=x_pred, trainX=x_train, trainY=y_train)) testthat::expect_length(name_warns, 2) testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.", name_warns, 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) }) ## Test passed with 68 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). # glmnet's own C++ convergence nag fires on this fixture. It is not # asserted, because that would pin a foreign optimizer's behavior, which can # differ across glmnet versions, platforms and BLAS. The predicate matches # glmnet's shared C++-error prefix, so it muffles that whole class -- a # tighter one would pin the very detail we are avoiding. Every non-glmnet # warning from this call still reaches the reporter (#186). css_no_train <- withCallingHandlers( css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10), warning = function(w) { if (grepl("from glmnet C++ code", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) # 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) }) ## 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)) }) ## Test passed with 20 successes. "],["tests-for-other-useful-functions.html", "10 Tests for other useful functions", " 10 Tests for other useful functions Tests for checkGenClusteredDataInputs() testthat::test_that("checkGenClusteredDataInputs works", { set.seed(7612) # Should get no error checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) # sig_clusters testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters="2", rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=4, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters <= n_clusters is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=-1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=.6, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters == round(sig_clusters) is not TRUE", fixed=TRUE) # n_clusters testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters="3", sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3.2, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters == round(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=0, sig_clusters=0, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=1, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "cluster_size >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=16, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "p >= n_clusters * cluster_size + k_unclustered is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "rho > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=0, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "beta_latent != 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=0, snr=1, sigma_eps_sq=NA), "beta_unclustered != 0 is not TRUE", fixed=TRUE) # k_unclustered testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered="2", cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=0, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2.2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered == round(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=NA), "Must specify one of snr or sigma_eps_sq", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) }) ## Test passed with 18 successes. Tests for getNoiseVar(): testthat::test_that("getNoiseVar works", { # getNoiseVar(rho) returns the noise variance v such that a proxy Z + N(0, v) # has correlation rho with Z, i.e. v = 1/rho^2 - 1 (vectorized; rho in (0, 1]). testthat::expect_equal(getNoiseVar(1), 0) testthat::expect_equal(getNoiseVar(0.5), 3) testthat::expect_equal(getNoiseVar(0.9), 1/0.81 - 1) testthat::expect_equal(getNoiseVar(c(0.5, 1, 0.9)), c(3, 0, 1/0.81 - 1)) # The defining property: a proxy with this noise variance has correlation rho. testthat::expect_equal(1/sqrt(1 + getNoiseVar(0.8)), 0.8) # rho must be numeric, non-NA, non-empty, and in (0, 1] (checks are vectorized). testthat::expect_error(getNoiseVar(0), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(-0.5), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(c(0.5, 0)), "all(rho > 0) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(1.5), "all(rho <= 1) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(NA_real_), "all(!is.na(rho)) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar("0.5"), "is.numeric(rho) | is.integer(rho) is not TRUE", fixed=TRUE) testthat::expect_error(getNoiseVar(numeric(0)), "length(rho) >= 1 is not TRUE", fixed=TRUE) }) ## Test passed with 12 successes. Finally, tests for genClusteredData() testthat::test_that("genClusteredData works", { set.seed(23478) ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:5])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:10])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:15])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .6) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 5) testthat::expect_equal(ncol(ret$Z), 1) # Bad inputs testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters="2", rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=4, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters <= n_clusters is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=-1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=.6, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "sig_clusters == round(sig_clusters) is not TRUE", fixed=TRUE) # n_clusters testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters="3", sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3.2, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters == round(n_clusters) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=0, sig_clusters=0, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "n_clusters >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=1, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "cluster_size >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(p=16, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "p >= n_clusters * cluster_size + k_unclustered is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "rho > 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=0, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "beta_latent != 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=0, snr=1, sigma_eps_sq=NA), "beta_unclustered != 0 is not TRUE", fixed=TRUE) # k_unclustered testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered="2", cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=0, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2.2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA), "k_unclustered == round(k_unclustered) is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=NA), "Must specify one of snr or sigma_eps_sq", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=0.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredData(n=5, p=19, k_unclustered=1, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(nrow(ret$X), 5) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 57 successes. Tests for genClusteredDataWeighted() testthat::test_that("genClusteredDataWeighted works", { set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:3])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:8])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:13])) > .9) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .7) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 1) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=1, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 38 successes. Tests for genClusteredDataWeightedRandom() testthat::test_that("genClusteredDataWeightedRandom works", { set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$X)) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 19) testthat::expect_equal(nrow(ret$X), 25) # X is Gaussian with mean 0 and variance 4; expect all observations to lie # within 5 standard deviations of mean testthat::expect_true(all(abs(ret$X) < 5*2)) # Test that clusters are correlated--within-cluster correlation should be # high, correlation with other features should be low testthat::expect_true(min(cor(ret$X[, 1:3])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6) testthat::expect_true(min(cor(ret$X[, 6:8])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 6:10], ret$X[, c(1:5, 11:19)]))) < .6) testthat::expect_true(min(cor(ret$X[, 11:13])) > .2) testthat::expect_true(max(abs(cor(ret$X[, 11:15], ret$X[, c(1:10, 16:19)]))) < .7) cor_indeps <- cor(ret$X[, 16:19]) testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6) testthat::expect_true(is.numeric(ret$y)) testthat::expect_equal(length(ret$y), 25) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 3) testthat::expect_true(is.numeric(ret$mu)) testthat::expect_equal(length(ret$mu), 25) # Because y is Gaussian with mean mu and standard deviation .5 conditional on # mu, expect all observations to lie within 5 sds of mu testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5)) # Specify SNR instead of sigma_eps_sq ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=1, sigma_eps_sq=NA) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of # the two may be given. testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=.01, sigma_eps_sq=.25), "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE) # Try a single latent variable (z should be a one-column matrix) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.numeric(ret$Z)) testthat::expect_true(is.matrix(ret$Z)) testthat::expect_equal(nrow(ret$Z), 25) testthat::expect_equal(ncol(ret$Z), 1) # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=0) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ret$y, ret$mu) # k_unclustered = 1 is allowed (issue #13) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=1, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 19) }) ## Test passed with 38 successes. Finally, characterization snapshots that pin the exact generated output of all three genClusteredData* generators. The “… works” tests above only check distributional properties (correlations, ranges), not the exact RNG draw order (which differs across the three: bulk rnorm vs per-column vs random per column). These snapshots make the #16 consolidation of the generators and their validators provably behavior-preserving; regenerate only if the data-generating algorithm intentionally changes. # Characterization snapshots: pin the EXACT generated values (X / y / Z / mu) # under fixed seeds so the #16 consolidation of the genClusteredData* functions # and their validators is provably behavior-preserving. The existing "... works" # tests only check distributional properties (correlations, ranges), NOT the # exact RNG draw order, which differs across the three generators (bulk vs # per-column vs random-per-column). Regenerate ONLY if the data-generating # algorithm intentionally changes. testthat::test_that("genClusteredData output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528, -0.113749750828501, -0.0540798505887575, -0.719018251689331, -1.02002920513898, -0.133167075802704, -0.228504275273568, -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392, -0.949501763500117, -1.09911307059764, -0.234373142554013, -0.0610136281766905, -0.614831158775111, -0.875588846521461, -0.267096146835881, 0.243882464912086, -0.525573959766865, 0.38889466127034, -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 7.85857128981734, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1): Z is a one-column matrix, and the # proxy block adds bulk noise to the raw vector Z. set.seed(23478) ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-0.00161764234876749, -0.557794858227907, -0.827386446973581, -0.460377784885637, -2.67619233265038, 0.671711827459298, 1.65236925524076, -0.600115109545631, -0.280741265470752, -1.67026187144442, -0.0473803806232191, 0.0826508004462609, 0.170200984778884, 0.976190994120857, -0.499749723868518, -0.474295388720649, -1.17346153974724, -0.574655697546479, -0.120791507647279, -0.567678976454219, -1.3596277359555, -0.0619416164679036, 0.538496824968004, 0.51591446765952), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-0.558336409902388, -2.73369761842788, -0.884087327686163, -3.17343267752372)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(0.195781398124046, -1.51661095607912, -0.722190912632797, -2.90119777610212)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -5.88971766152033, sumY = -7.36101068003228, sumZ = -2.4782435456402, sumMu = -5.08843939501818)) }) testthat::test_that("genClusteredDataWeighted output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528, -0.113749750828501, -0.0540798505887575, -0.719018251689331, -1.02002920513898, -0.133167075802704, -0.228504275273568, -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392, -0.949501763500117, -0.748805376677026, 0.925796953277494, -0.766705940388196, -0.348877774329742, 1.96822115764394, 0.528035720534176, 2.93942827641455, 0.736079254765787, 0.38889466127034, -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 15.3829830134111, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1) set.seed(23478) ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.07114417787482, -0.368013007285506, 0.014438919713251, -0.845503147886515, -1.23739163512048, -0.174811089926991, -0.0829364724064908, -0.479069797377207, -1.12138274604786, -0.402828108682171, 0.104291325515473, -0.844159398768831, 0.352430473911601, -1.4960796572646, -1.23544829374631, 0.148162490964714, -1.03021388828778, 0.576416731940481, -0.513340292522171, -1.14008022670496, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795, 0.513991031913566, -2.95972727928473)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239, 0.564187042362111, -2.19774596140566)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -24.0234160115409, sumY = -10.2198990332918, sumZ = 0.586596841562748, sumMu = -5.15679097838167)) }) testthat::test_that("genClusteredDataWeightedRandom output is byte-stable (characterization snapshot, #16)", { set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.1897691657824, -0.00982041549935259, 0.665172439447775, -0.756543570417209, 1.15949678203449, -2.91344510959381, 0.491240389956153, -1.30476423524191, -0.485131132932798, 0.707045727376943, 3.2222522503854, -3.27350445562509, -1.85428176680484, -0.0656090373877866, -0.551130785327929, -1.90090513408521, -1.29616909361208, -0.144918159176611, 0.544180897409365, -0.50148178532334, 0.627200376817289, 0.171599744439457, -1.07507438640901, 1.5693792481444), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328, 0.0881535457958548, 1.21771079504409)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552, 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439), dim = 4:3)) testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772, -0.106753094432726, 1.52394871772745)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = 3.23025166163967, sumY = 13.5810460445817, sumZ = 3.15823002771053, sumMu = 9.93005749962466)) # single latent variable (n_clusters = 1) set.seed(23478) ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.36526166060881, 0.586409931283558, 1.2227469255493, -2.17655371414979, 0.326418806550987, -1.09714072579561, 1.4239012653582, -0.760011975131564, -0.227256340192126, -1.84845832529723, 0.184388770399019, -0.394752299747441, -1.47062212216842, -0.12215942773548, -0.0749451055463801, -0.842364831584477, -1.41223753691949, -1.68487949598676, 0.247717311839652, -1.86068883953814, 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L))) testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795, 0.513991031913566, -2.95972727928473)) testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852, -0.338373896594486, 0.00224652036037424, -0.638671932314538), dim = c(4L, 1L))) testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239, 0.564187042362111, -2.19774596140566)) testthat::expect_equal( c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)), c(sumX = -28.8273582900822, sumY = -10.2198990332918, sumZ = 0.586596841562748, sumMu = -5.15679097838167)) }) ## Test passed with 10 successes. ## Test passed with 10 successes. ## Test passed with 10 successes. The two weighted generators now run the same snr / sigma_eps_sq type checks as genClusteredData() (#35): a non-numeric snr / sigma_eps_sq is rejected up front rather than silently passing the old lean check and failing later inside genZmuY(). testthat::test_that("genClusteredData* reject n < 2 and non-integer cluster_size / p (#70)", { ok <- list(n = 10, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1, sig_clusters = 1, sigma_eps_sq = 1) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(n = 1L))), "n >= 2", fixed = TRUE) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(cluster_size = 2.5))), "cluster_size == round(cluster_size)", fixed = TRUE) testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(p = 8.5))), "p == round(p)", fixed = TRUE) # n = 2 is the tight boundary -- it must still WORK (locks the threshold # against a future "n >= 3" / "> 2" regression). res2 <- do.call(genClusteredData, utils::modifyList(ok, list(n = 2L))) testthat::expect_equal(nrow(res2$X), 2L) # The shared genZmuY n-guard and the shared Pre cluster_size check cover the # weighted generators too: wok <- list(n = 1L, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1, n_strong_cluster_vars = 2, sig_clusters = 1, rho_high = 0.8, rho_low = 0.2, sigma_eps_sq = 1) testthat::expect_error(do.call(genClusteredDataWeighted, wok), "n >= 2", fixed = TRUE) testthat::expect_error( do.call(genClusteredDataWeighted, utils::modifyList(wok, list(n = 10L, cluster_size = 2.5))), "cluster_size == round(cluster_size)", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted/Random validate snr/sigma_eps_sq type (#35)", { # Newly rejected (these previously slipped past the weighted validators' lean # checks and only failed later, cryptically, inside genZmuY). testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1", sigma_eps_sq=NA), "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"), "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1", sigma_eps_sq=NA), "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"), "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE) # Range checks (snr > 0, sigma_eps_sq >= 0) are unchanged by #35. testthat::expect_error( genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=-.2, sigma_eps_sq=NA), "snr > 0 is not TRUE", fixed=TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3), "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE) # A valid scalar numeric snr / sigma_eps_sq is still accepted. ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5, n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99, rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) }) testthat::test_that("genClusteredData rejects rho > 1 up front (#162)", { # The documented upper bound is now enforced by the up-front checker, so the # message names the user's argument rho instead of surfacing from deep # inside getNoiseVar(). Split one case per block: under testthat edition 3, # which this package declares, expect_error() re-raises on a message mismatch # and aborts the rest of its block, so bundling would hide the red side of # every case after the first. The edition is load-bearing -- at edition 2 the # block continues instead, so measuring this outside a package context (where # edition 2 is the default) measures the wrong semantics. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1.2, sigma_eps_sq = 1), "rho <= 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects a non-numeric rho (#162)", { # Without the type check this slipped through: stopifnot("0.8" > 0) is TRUE, # because R compares character to numeric as strings. It then failed later, # inside getNoiseVar(). # # The message alone stopped being a sufficient guard when #181 renamed # getNoiseVar()'s formal cor -> rho: the validator's check and getNoiseVar()'s # are now the SAME line, so both raise # is.numeric(rho) | is.integer(rho) is not TRUE # and the string can no longer tell "rejected up front" from "died late # inside getNoiseVar()". Measured: deleting the validator's type check leaves # this block green if it pins only the message, because "0.8" > 0 and # "0.8" <= 1 are both TRUE (string comparison), so a character rho reaches # genZmuY(), draws from the stream, and dies in getNoiseVar() raising the # identical condition. # # The RNG state distinguishes the two frames no matter what the message says, # and early rejection is what #162 was actually about -- so assert it here # rather than relying on a string that two independent guards now share. set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = "0.8", sigma_eps_sq = 1), "is.numeric(rho) | is.integer(rho) is not TRUE", fixed = TRUE) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredData rejects a length > 1 rho (#162)", { # Previously NO error at all. A length-2 rho produced a length-2 noise # variance, which rnorm() recycles elementwise over its flat draw, so the # noise sd alternated row by row WITHIN every proxy column. Measured on the # pre-fix code with rho = c(0.9, 0.5) and seed 1, the eight proxy # correlations were 0.58 0.25 0.55 0.52 0.47 0.60 0.58 0.47 -- every one # corrupted, none at either requested value. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = c(0.9, 0.5), sigma_eps_sq = 1), "length(rho) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects a missing rho (#162)", { # Previously reported the misleading "rho > 0 is not TRUE". testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = NA_real_, sigma_eps_sq = 1), "!is.na(rho) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData rejects rho before drawing any random numbers (#162)", { # "Up front" is the point of the issue, so assert it directly: a rejected # rho must not have advanced the RNG. Before the fix, rho = 1.2 died inside # getNoiseVar() only after genZmuY() had already drawn from the stream. # The expect_error() below deliberately asserts no message: this block's # subject is the RNG state, and the message for this exact input is already # pinned by the "rejects rho > 1 up front" block above. set.seed(20260815) seed_before <- .Random.seed testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1.2, sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredData keeps rejecting rho <= 0 (#162)", { # The lower bound is unchanged; this locks its message against the reorder. testthat::expect_error( genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 0, sigma_eps_sq = 1), "rho > 0 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredData accepts rho = 1, the tight upper boundary (#162)", { # rho = 1 must still WORK, so the new bound is <= and not <. getNoiseVar(1) # is exactly 0, so every proxy is a noiseless copy of its latent column -- # a seed-independent identity, and a far stronger lock than dim(X), which # would hold at any rho. set.seed(20260815) res <- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho = 1, sigma_eps_sq = 1) testthat::expect_equal(dim(res$X), c(50L, 13L)) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res$X[, 1:8], Z_expanded) }) testthat::test_that("genClusteredDataWeighted enforces the documented n_strong_cluster_vars range (#162, refs #164)", { # Both bounds already errored; these are the negative tests that were # missing (#164) for the constraint now documented on the help page. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 0, n_clusters = 2, sigma_eps_sq = 1), "n_strong_cluster_vars >= 1 is not TRUE", fixed = TRUE) # An all-strong cluster is a natural request and is rejected: the second # proxy loop would run (cluster_size + 1):cluster_size, which descends # rather than being empty, so it writes the NEXT cluster's first proxy # column -- and on the final cluster that index is past ncol(proxy_mat), so # the unguarded loop dies with "subscript out of bounds". The guard trades # that obscure indexing error for one naming the argument. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 4, n_clusters = 2, sigma_eps_sq = 1), "n_strong_cluster_vars < cluster_size is not TRUE", fixed = TRUE) # Interior values are accepted AND split the columns as documented. With # rho_high = 1 the strong proxies are noiseless copies of their latent # column and the weak ones are not, which locks the split itself rather # than just the shape of X. n = 500 rather than 50 so that the weak-proxy # correlation check below discriminates: measured at n = 50, a rho_low = 0.5 # proxy's sample correlation was 0.33 while pure independent noise reached # 0.48 over 200 draws, so any threshold there would be vacuous. At n = 500 # the weak proxies measure ~0.53 and pure noise tops out at 0.16. set.seed(20260815) res <- genClusteredDataWeighted(n = 500, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = 0.5, sigma_eps_sq = 1) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] strong <- c(1:3, 5:7) weak <- c(4L, 8L) testthat::expect_equal(res$X[, strong], Z_expanded[, strong]) testthat::expect_false(any(res$X[, weak] == Z_expanded[, weak])) # The weak proxies must still carry the latent signal at roughly rho_low, and # this is a two-sided band rather than a floor on purpose. A one-sided # "> 0.3" passes a bug that hands the weak proxies rho_high instead # (measured: weak_cor 0.951, 0.956) -- which is precisely the strong/weak # split failure this block exists to catch, so a floor would be blind to it. # At n = 500 the sampling sd of the correlation is ~0.034 and the seed is # fixed, so a 0.1 band is ~3 sd wide: the correct values sit 0.028 and 0.040 # away from rho_low, while pure noise (~0) and a rho_high mix-up (~0.95) both # fall well outside. weak_cor <- vapply(weak, function(j) stats::cor(res$X[, j], Z_expanded[, j]), numeric(1)) testthat::expect_true(all(abs(weak_cor - 0.5) < 0.1)) testthat::expect_false(anyNA(res$X)) }) testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_high (#181)", { # Previously slipped past all four range checks and died inside # getNoiseVar(), naming that helper's formal rather than the user's # argument, and only after the RNG had already advanced. The type check has # to precede every range check: stopifnot("0.9" >= 0.5) is TRUE, because R # coerces the number to a string and compares as strings rather than # erroring. ("10" >= 9 is FALSE, which is the giveaway that it is a string # comparison and not a numeric one.) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_high (#181)", { # The same hole with a different landing place: this generator reached # runif(n = 1, min = rho_low, max = rho_high) and reported the opaque # "invalid arguments", again only after advancing the RNG. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_low (#181)", { # As for rho_high: the string comparison rho_high >= rho_low is TRUE for # "0.2", so the old range checks passed it straight through to getNoiseVar(). testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = "0.2", sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_low (#181)", { # Previously reported runif()'s "invalid arguments", after advancing the RNG. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = "0.2", sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a logical rho_high (#181)", { # A logical argument is the same type hole, but the two generators failed # very differently. genClusteredDataWeighted() errored naming getNoiseVar()'s # formal, while genClusteredDataWeightedRandom() accepted TRUE outright (the # block below) -- so the pair belongs to the silent-wrong-answer class, not # merely the bad-message class. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_high (#181)", { # Previously NO error at all: runif(1, 0.5, TRUE) coerces TRUE to 1, so the # call returned a data set silently generated at rho_high = 1 instead of # rejecting an argument that is not a correlation. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1), "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a logical rho_low (#181)", { # rho_high = 1 is deliberate. This input errors at either setting, but at # rho_high = 1 the pre-change code advanced the RNG before dying inside # getNoiseVar(), whereas at rho_high = 0.9 the ordering check caught it with # the stream untouched -- blaming the ordering for what is a type error. The # rho_high = 1 variant is the worse defect, so it is the one to lock. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_low (#181)", { # rho_high = 1 is load-bearing here for a different reason: it is this # generator's DEFAULT, and the only setting under which rho_low = TRUE was # accepted at all -- runif(1, TRUE, 1) coerces TRUE to 1, so the call # silently returned data. A silent wrong answer on the default path. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1), "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_high (#181)", { # Previously NO error at all -- the silent-wrong-answer case this issue was # filed about. genClusteredDataWeighted() calls getNoiseVar() once per # argument and then draws per column, rnorm(n, sd = sqrt(noise_var_high)), # so a length-2 argument makes sd length 2 and rnorm() recycles it # elementwise DOWN the column: the noise sd alternates row by row within # every column that argument governs. The columns governed by the other, # scalar argument keep exactly the correlation they asked for. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_high (#181)", { # Previously NO error either, but by a different route: this generator does # no recycling at all. The argument reaches # runif(n = 1, min = rho_low, max = rho_high), which uses the FIRST element # and discards the rest without a word. Truncation, not corruption -- the # two generators are not failing the same way. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_low (#181)", { # Previously NO error, and this is the case whose corrupted value has a # closed form worth recording. Recycling sd = sqrt(c(3, 10.1111)) # elementwise down a column makes the noise VARIANCE alternate, so the # column's marginal noise variance is the mean of the two and BOTH weak # columns land on # 1/sqrt(1 + mean(c(getNoiseVar(0.5), getNoiseVar(0.3)))) = 1/sqrt(1 + # 6.5556) = 0.3638 -- neither requested value, and identical for the two of # them. That is the population value, not a sample estimate: quoting a # measured pair would imply a between-column difference that does not exist, # and every seed produces a different pair. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1), "length(rho_low) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_low (#181)", { # Previously NO error: the same first-element truncation as for rho_high. # Measured on the pre-change tree at a fixed seed, the returned X was # identical() to the rho_low = 0.5 run and not to the rho_low = 0.3 run. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3), sigma_eps_sq = 1), "length(rho_low) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a zero-length rho_high (#181)", { # All four range checks are STRUCTURALLY INERT against a zero-length # argument: numeric(0) <= 1 is logical(0), and all(logical(0)) is TRUE, so # stopifnot() does not error. The call therefore reached getNoiseVar() and # reported that helper's formal. NULL is in the same family but is NOT # interchangeable -- is.numeric(NULL) is FALSE, so NULL is caught by the # TYPE check and never reaches the length check. numeric(0) is the input # that exercises the length check at its zero end. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a zero-length rho_high (#181)", { # The same inert range checks. Here the call got as far as runif(), which # returned NA with a "NAs produced" warning, and the failure then surfaced # from inside getNoiseVar() rather than naming rho_high. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a missing rho_high (#181)", { # Previously reported the misleading "rho_high <= 1 is not TRUE" -- a range # bound blamed for a missingness problem, which sends the user off checking # a value that is not the issue. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1), "!is.na(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_high (#181)", { # Same misleading "rho_high <= 1 is not TRUE" before the change. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1), "!is.na(rho_high) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted rejects a missing rho_low (#181)", { # Previously reported "rho_low > 0 is not TRUE" -- the lower bound this # time rather than the upper one, but the identical class: a range bound # blamed for missingness. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = NA_real_, sigma_eps_sq = 1), "!is.na(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_low (#181)", { # Same misleading "rho_low > 0 is not TRUE" before the change. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = NA_real_, sigma_eps_sq = 1), "!is.na(rho_low) is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted checks rho_high's length before its missingness (#181)", { # This block exists for the FINE ordering -- length before NA -- which every # other block here is blind to. Only an input that is simultaneously length # > 1 AND contains NA can tell the two orderings apart: measured, the # shipped order reports the length violation below, while checking !is.na() # first reports the confusing plural "!is.na(rho_high) are not all TRUE", # because !is.na() is vectorized. Before the change this input reported # neither, dying in the range checks with "rho_high <= 1 are not all TRUE". testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeightedRandom checks rho_high's length before its missingness (#181)", { # The fine-ordering lock for the second generator; see the block above for # why an input that is both length > 1 and NA-containing is the only one # that distinguishes the two orderings. testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1), "length(rho_high) == 1 is not TRUE", fixed = TRUE) }) testthat::test_that("genClusteredDataWeighted* reject rho_high/rho_low before drawing any random numbers (#181)", { # "Up front" is the point of the issue, so assert it directly. A length-2 # argument is the right probe: it advanced the RNG in both generators before # the change, whereas an NA argument was already caught by a range check # with the stream untouched and so would prove nothing. # This block stays BUNDLED across both generators, unlike every block above. # Its expect_error() calls carry no message argument, so they cannot # mismatch, so they cannot re-raise and abort the block under testthat # edition 3 -- all four assertions are reached even when all four fail. set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) set.seed(20260817) seed_before <- .Random.seed testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3), sigma_eps_sq = 1)) testthat::expect_identical(.Random.seed, seed_before) }) testthat::test_that("genClusteredDataWeighted* still accept the boundary rho values (#181)", { # rho = 1 must still WORK, so the bound is <= and not <. getNoiseVar(1) is # exactly 0, so every proxy is a noiseless copy of its latent column -- a # seed-independent identity, and a far stronger lock than dim(X), which # would hold at any rho. Passing rho_high = rho_low = 1 hits the upper # boundary and the rho_high == rho_low boundary at once. set.seed(20260817) res <- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1, rho_low = 1, sigma_eps_sq = 1) Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res$X[, 1:8], Z_expanded) # rho_high is OMITTED here, so its default of 1 applies: one call covering # the upper boundary, the rho_high == rho_low boundary, and the default path # the issue's closing note asks about. runif(1, 1, 1) is exactly 1, so the # same noiseless identity holds for this generator too. set.seed(20260817) res_rand <- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_low = 1, sigma_eps_sq = 1) Z_expanded_rand <- as.matrix(res_rand$Z)[, rep(1:2, each = 4), drop = FALSE] testthat::expect_equal(res_rand$X[, 1:8], Z_expanded_rand) }) testthat::test_that("genClusteredDataWeighted* keep their existing rho range messages (#181)", { # What this locks, precisely: the four range checks survive the move into # checkRhoHighLow() with their exact messages. It is GREEN on the pre-change # tree by design -- it locks behavior that must not change, so its power # comes from mutation rather than from a red side. It is the only block in # this set that notices if one of the four checks is dropped. # # It does NOT lock their order, and two reorderings are invisible to it. # Swapping > 0 against <= 1 is invisible because once length-1 and non-NA # are established at most one of those two can fail on a scalar, so the # orders are observationally identical. Swapping rho_low > 0 against # rho_high >= rho_low is invisible for a different reason: measured, all # four inputs below report the same message either way, because whichever # of the two is violated is still the first of them to fail. testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1), "rho_high <= 1 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1), "rho_high > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1), "rho_low > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2, rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1), "rho_high >= rho_low is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1), "rho_high <= 1 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1), "rho_high > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1), "rho_low > 0 is not TRUE", fixed = TRUE) testthat::expect_error( genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2, cluster_size = 4, n_clusters = 2, rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1), "rho_high >= rho_low is not TRUE", fixed = TRUE) }) ## Test passed with 6 successes. ## Test passed with 7 successes. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 1 success. ## Test passed with 2 successes. ## Test passed with 6 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 4 successes. ## Test passed with 2 successes. ## Test passed with 8 successes. Edge-case regression tests for genZmuY() (the shared core all three generators funnel through), covering the two bugs fixed in #124: a missing drop = FALSE that crashed the exactly-one-weak-signal/noise-feature configuration, and a sig_clusters == 0 case that silently kept a latent cluster in the true model for y instead of yielding a null latent model. The fix consumes NO randomness (only deterministic reshaping of mu), so every generator test and characterization snapshot above stays byte-identical. testthat::test_that("genZmuY one-weak-signal config no longer crashes, all 3 generators (#124 bug 1)", { # p == n_clusters*cluster_size + 1 leaves exactly ONE weak-signal/noise # feature, so other_X had a single column; without drop = FALSE it collapsed # to a vector and other_X[, j] errored "incorrect number of dimensions". The # pre-check only requires p_orig_feat_mat >= k_unclustered + n_clusters # (here 2 >= 2), so it passed straight into the crash. ret <- genClusteredData(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, snr = 2) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_true(is.matrix(ret$X)) testthat::expect_equal(ncol(ret$X), 3) testthat::expect_equal(nrow(ret$X), 20) # genClusteredDataWeighted: n_strong_cluster_vars is REQUIRED and its checker # enforces >= 1 AND < cluster_size, so with cluster_size = 2 the only valid # value is 1. retW <- genClusteredDataWeighted(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, n_strong_cluster_vars = 1, snr = 2) testthat::expect_true(is.list(retW)) testthat::expect_identical(names(retW), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(retW$X), 3) retR <- genClusteredDataWeightedRandom(n = 20, p = 3, k_unclustered = 1, cluster_size = 2, n_clusters = 1, snr = 2) testthat::expect_true(is.list(retR)) testthat::expect_identical(names(retR), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(retR$X), 3) }) testthat::test_that("genZmuY sig_clusters == 0 yields a null latent model (#124 bug 2)", { # The zero-beta case MUST bypass genClusteredData: its validator rejects # beta_unclustered == 0 / beta_latent == 0, so exercise the internal helper # directly. sig_clusters == 0 AND beta_unclustered == 0 => mu is exactly 0 # (no latent term, no weak-signal term). set.seed(53) g0 <- genZmuY(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, sig_clusters = 0, beta_latent = 1.5, beta_unclustered = 0, snr = NA, sigma_eps_sq = 0.5) testthat::expect_true(all(g0$mu == 0)) # Contrast, n_clusters > 1: reset the seed before EACH call so the SAME # orig_feat_mat (hence the same Z and weak-signal block) is drawn; then # g1$mu - g0$mu isolates the pure latent term Z[, 1] * beta_latent. cfgA <- list(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, beta_latent = 1.5, beta_unclustered = 1, snr = NA, sigma_eps_sq = 0.5) set.seed(51) g0A <- do.call(genZmuY, c(cfgA, sig_clusters = 0)) set.seed(51) g1A <- do.call(genZmuY, c(cfgA, sig_clusters = 1)) testthat::expect_equal(g1A$Z, g0A$Z) # same orig_feat_mat drawn testthat::expect_false(all(g0A$mu == 0)) # weak signal still retained testthat::expect_equal(g1A$mu - g0A$mu, as.numeric(g1A$Z[, 1] * 1.5)) # Lock the n_clusters > 1 & sig_clusters == 1 branch with an explicit # expected value (no characterization snapshot covers it). testthat::expect_equal(g1A$mu[1:4], c(1.71187484261165, -1.8816097377914, -0.434623721956133, 0.201053072650191)) # Contrast, n_clusters == 1 (Z is a bare vector; the else branch). cfgB <- list(n = 20, p = 4, k_unclustered = 1, cluster_size = 2, n_clusters = 1, beta_latent = 1.5, beta_unclustered = 1, snr = NA, sigma_eps_sq = 0.5) set.seed(52) g0B <- do.call(genZmuY, c(cfgB, sig_clusters = 0)) set.seed(52) g1B <- do.call(genZmuY, c(cfgB, sig_clusters = 1)) testthat::expect_equal(g1B$mu - g0B$mu, as.numeric(g1B$Z * 1.5)) testthat::expect_equal(g1B$mu[1:4], c(-1.35778032140589, 0.59232273049822, 2.44822804281879, -0.29256382836018)) # End-to-end: genClusteredData with sig_clusters = 0 and NONZERO default # betas returns valid data (no error; the weak-signal features still # legitimately contribute, only the latent part is zeroed). ret <- genClusteredData(n = 20, p = 6, k_unclustered = 1, cluster_size = 2, n_clusters = 2, sig_clusters = 0, sigma_eps_sq = 0.5) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("X", "y", "Z", "mu")) testthat::expect_equal(ncol(ret$X), 6) }) ## Test passed with 11 successes. ## Test passed with 10 successes. Tests for getLassoLambda(): testthat::test_that("getLassoLambda works", { set.seed(7252) x <- matrix(stats::rnorm(10*6), nrow=10, ncol=6) y <- stats::rnorm(10) ret <- getLassoLambda(X=x, y=y, lambda_choice="1se", nfolds=4) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) # Different mixing parameter ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5, alpha=0.5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret >= 0) # data.frame X is now accepted (coerced internally), like the sibling exports (#51) ret_df <- getLassoLambda(X = as.data.frame(x), y = y, lambda_choice = "1se", nfolds = 4) testthat::expect_true(is.numeric(ret_df) | is.integer(ret_df)) testthat::expect_true(!is.na(ret_df)) testthat::expect_equal(length(ret_df), 1) testthat::expect_true(ret_df >= 0) # Bad inputs testthat::expect_error(getLassoLambda(X="x", y=y), "must be a numeric matrix", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x[1:9, ], y=y), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=TRUE), "must be a numeric (real-valued) vector", fixed=TRUE) # Error has quotation marks in it testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice="mni")) testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=c("min", "1se")), "length(lambda_choice) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=1), "is.character(lambda_choice) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds="5"), "is.numeric(nfolds) | is.integer(nfolds) is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=1:4), "length(nfolds) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=3.2), "nfolds == round(nfolds) is not TRUE", fixed=TRUE) # (#158e) nfolds=3 is cv.glmnet's minimum and is now accepted. ret <- getLassoLambda(X=x, y=y, nfolds=3) testthat::expect_true(is.numeric(ret) && length(ret) == 1 && ret >= 0) # nfolds=2 (below the minimum) is rejected at the new boundary. testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=2), "nfolds >= 3 is not TRUE", fixed=TRUE) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=1.2), "alpha <= 1 is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is now rejected (previously allowed) testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # An NA in the design matrix now yields a friendly message (#56) rather than # falling through to a cryptic glmnet-level error. x_na <- x; x_na[2, 1] <- NA testthat::expect_error(getLassoLambda(X=x_na, y=y), "must not contain missing", fixed=TRUE) # A data.frame with a numeric NA must error with the same message BEFORE # coercion: model.matrix's na.action=na.omit would otherwise silently drop # the NA row and the failure would surface downstream (length mismatch), not # as this message. This case pins the pre-coercion placement of checkNoNAs. df_na <- as.data.frame(x); df_na[2, 1] <- NA testthat::expect_error(getLassoLambda(X=df_na, y=y), "must not contain missing", fixed=TRUE) # (#104, L7) When n is too small for even 3-fold cross-validation, error # clearly here instead of crashing inside cv.glmnet ("nfolds must be bigger # than 3"). With n = 4 and the default nfolds = 10, n_sample rounds to 2 (< 3). testthat::expect_error( getLassoLambda(X=matrix(stats::rnorm(4*5), nrow=4, ncol=5), y=stats::rnorm(4)), "is too small to choose lambda", fixed=TRUE) # (#127) A single-column X now fires the same clean "p >= 2 is not TRUE" # message as css(), rather than crashing later inside cv.glmnet. testthat::expect_error( getLassoLambda(X=matrix(stats::rnorm(40), nrow=40, ncol=1), y=stats::rnorm(40)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 33 successes. Out-of-range cluster indices are caught up front (#104, L3) through the public css() and protolasso() entry points – covering a bare-vector clusters argument (which is wrapped into a list after the per-element validation loop) and a list clusters argument: testthat::test_that("out-of-range cluster indices error via css/protolasso (#104)", { set.seed(104105) X <- matrix(stats::rnorm(20*8), nrow=20, ncol=8) y <- stats::rnorm(20) # Bare-vector clusters with an index beyond p (= 5 here). testthat::expect_error( css(X[, 1:5], y, lambda=0.01, clusters=c(1, 2, 99)), "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE) # List clusters routed through protolasso. testthat::expect_error( protolasso(X[, 1:5], y, clusters=list(c(1, 2, 99))), "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE) }) ## Test passed with 2 successes. css() reports a too-small sample size clearly (#104, L4) instead of the misleading “Too many training indices provided” when no training indices were supplied: testthat::test_that("css reports a too-small sample size clearly (#104)", { set.seed(104104) # No train_inds: the message must blame the sample size, not training indices. testthat::expect_error( css(matrix(stats::rnorm(15), nrow=3, ncol=5), stats::rnorm(3), lambda=0.01), "is too small", fixed=TRUE) # When train_inds leave fewer than 4 observations for selection, the original # "Too many training indices" branch still fires. testthat::expect_error( css(matrix(stats::rnorm(10*5), nrow=10, ncol=5), stats::rnorm(10), lambda=0.01, train_inds=1:7), "Too many training indices provided", fixed=TRUE) }) ## Test passed with 2 successes. Tests for getModelSize(): testthat::test_that("getModelSize works", { set.seed(1723) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) ret <- getModelSize(X=x, y=y, clusters=good_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but two clusters of size 3, so maximum size should # be 11 - 2 - 2 = 7 testthat::expect_true(ret <= 7) ## Trying other inputs unnamed_clusters <- list(1L:3L, 5L:8L) ret <- getModelSize(X=x, y=y, clusters=unnamed_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 3 in one cluster and 4 in another, so maximum size should # be 11 - 2 - 3 = 6 testthat::expect_true(ret <= 6) # Single cluster ret <- getModelSize(X=x, y=y, clusters=2:5) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 4 in one cluster, so maximum size should be 11 - 3 = 8 testthat::expect_true(ret <= 8) # Regression test: when prototype reduction leaves a single column (all # provided features in one cluster), getModelSize must return 1L rather than # crashing in cv.glmnet. Previously X_size[, -feats_to_drop] dropped to a # vector when one column remained. testthat::expect_equal(getModelSize(X=x[, 1:3, drop=FALSE], y=y, clusters=list(1:3)), 1L) # Intentionally don't provide clusters for all feature, mix up formatting, # etc. good_clusters <- list(red_cluster=1:3, 5:8) ret <- getModelSize(X=x, y=y, clusters=good_clusters) testthat::expect_true(is.numeric(ret) | is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_equal(ret, round(ret)) testthat::expect_true(ret >= 1) # 11 features, but 3 in one cluster and 4 in another, so maximum size should # be 11 - 2 - 3 = 6 testthat::expect_true(ret <= 6) ## Trying bad inputs testthat::expect_error(getModelSize(X="x", y=y, clusters=good_clusters), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x[1:5, ], y=y, clusters=good_clusters), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=FALSE, clusters=good_clusters), "must be a numeric (real-valued) vector", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(3:7, 7:10)), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): the model size for a # duplicated cluster equals that of the deduplicated input. getModelSize is # stochastic (cv.glmnet), so seed both calls identically. set.seed(15678) dup_ms <- getModelSize(X=x, y=y, clusters=list(5:8, 5:8)) set.seed(15678) dedup_ms <- getModelSize(X=x, y=y, clusters=list(5:8)) testthat::expect_equal(dup_ms, dedup_ms) # Out-of-range cluster index now caught up front by checkFormatClustersInput # (#104, L3); x has 11 columns, so index 50 is out of range. testthat::expect_error(getModelSize(X=x, y=y, clusters=6:50), "Cluster index 50 exceeds the number of features (p = 11).", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, as.integer(NA))), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, c(4, 4, 5))), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, -1)), "all(clusters[[i]] >= 1) is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, c(2.3, 1.2))), "all(clusters[[i]] == round(clusters[[i]])) is not TRUE", fixed=TRUE) ## alpha (#21): the elastic-net mixing parameter now drives the model-size ## estimate (the internal cv.glmnet), keeping it consistent with elastic-net ## feature selection. # Validation, mirroring getLassoLambda: alpha must be in (0, 1]. testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=NA), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) # Back-compat: default is pure lasso (alpha = 1). cv.glmnet uses random CV # folds, so seed before each call to compare apples-to-apples. set.seed(7); a_default <- getModelSize(X=x, y=y, clusters=good_clusters) set.seed(7); a_alpha1 <- getModelSize(X=x, y=y, clusters=good_clusters, alpha=1) testthat::expect_equal(a_default, a_alpha1) # Headline: on a design with a block of highly correlated relevant features # (each feature its own singleton cluster, so cv.glmnet sees the whole block # with no prototype reduction), a lower alpha (elastic net) keeps more of the # correlated features than pure lasso, giving a strictly larger estimated # size. On main, getModelSize has no alpha argument, so this cannot happen. set.seed(2718) n_h <- 120 z_h <- stats::rnorm(n_h) X_block <- matrix(rep(z_h, 10), nrow=n_h) + matrix(stats::rnorm(n_h * 10, sd=0.05), nrow=n_h) X_noise <- matrix(stats::rnorm(n_h * 4), nrow=n_h) X_h <- cbind(X_block, X_noise) y_h <- 2 * z_h + stats::rnorm(n_h, sd=0.5) singletons_h <- as.list(1:ncol(X_h)) set.seed(11) size_lasso <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=1) set.seed(11) size_enet <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=0.2) testthat::expect_true(size_enet >= size_lasso) testthat::expect_true(size_enet > size_lasso) }) ## Test passed with 41 successes. These two functions are the package’s only cv.glmnet call sites, and #186’s fix is a grouped argument on each. This block is what observes that fix: testthat::test_that("small-n cv.glmnet calls do not leak glmnet's fold-size nag (#186)", { set.seed(186) X <- matrix(stats::rnorm(20 * 6), nrow = 20, ncol = 6) y <- as.numeric(X %*% c(1, -1, 0, 0, 0, 0) + stats::rnorm(20)) # n = 20 puts both calls under glmnet's nrow(x)/nfolds < 3 rule -- getLassoLambda # subsamples 11 rows over 10 folds, getModelSize passes all 20 over 10 -- so # without the explicit grouped argument cv.glmnet warns here. capture_warnings() # rather than expect_no_warning() because the woven chunks run at testthat # edition 2, where this form behaves the same as it does under devtools::test(). lambda_warns <- testthat::capture_warnings(lambda <- getLassoLambda(X = X, y = y)) testthat::expect_length(lambda_warns, 0) testthat::expect_true(is.numeric(lambda) & length(lambda) == 1) size_warns <- testthat::capture_warnings( size <- getModelSize(X = X, y = y, clusters = list(1:3))) testthat::expect_length(size_warns, 0) testthat::expect_true(is.integer(size) & size >= 1) # The user-visible half of #186: under options(warn = 2) the unguarded calls # became errors, so cssSelect()/cssPredict() were unusable at small n. old_warn <- options(warn = 2) on.exit(options(old_warn), add = TRUE) testthat::expect_no_error(getLassoLambda(X = X, y = y)) testthat::expect_no_error(getModelSize(X = X, y = y, clusters = list(1:3))) }) ## Test passed with 6 successes. Tests for getSelectionPrototypes(): testthat::test_that("getSelectionPrototypes works", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters) ret <- getSelectionPrototypes(css_results, selected_clusts=good_clusters) testthat::expect_true(is.integer(ret)) testthat::expect_true(all(!is.na(ret))) testthat::expect_equal(length(ret), length(good_clusters)) testthat::expect_equal(length(ret), length(unique(ret))) for(i in 1:length(ret)){ testthat::expect_true(ret[i] %in% good_clusters[[i]]) # Find the largest selection proportion of any feature in cluster i max_prop <- max(colMeans(css_results$feat_sel_mat[, good_clusters[[i]]])) # Find the selection proportion of the identified prototype proto_prop <- colMeans(css_results$feat_sel_mat)[ret[i]] testthat::expect_equal(max_prop, proto_prop) } # Try with only one selected cluster (still should be in a list) ret <- getSelectionPrototypes(css_results, selected_clusts=list(red_cluster=1L:3L)) testthat::expect_true(is.integer(ret)) testthat::expect_true(!is.na(ret)) testthat::expect_equal(length(ret), 1) testthat::expect_true(ret %in% 1L:3L) # Find the largest selection proportion of any feature in the cluster max_prop <- max(colMeans(css_results$feat_sel_mat[, 1L:3L])) # Find the selection proportion of the identified prototype proto_prop <- colMeans(css_results$feat_sel_mat)[ret] testthat::expect_equal(max_prop, proto_prop) ## Trying bad inputs # Error contains quotation marks testthat::expect_error(getSelectionPrototypes(x, good_clusters)) testthat::expect_error(getSelectionPrototypes(css_results, 1L:3L), "is.list(selected_clusts) is not TRUE", fixed=TRUE) # An empty selection (empty list of selected clusters) is valid post-#107: # getSelectionPrototypes() returns an empty integer vector, no error (#120). testthat::expect_identical(getSelectionPrototypes(css_results, list()), integer(0)) testthat::expect_error(getSelectionPrototypes(css_results, list(red_cluster=1L:3L, green_cluster=4L:6L, bad_cluster=integer())), "all(lengths(selected_clusts) >= 1) is not TRUE", fixed=TRUE) }) testthat::test_that("getSelectionPrototypes handles a constant tied column without crashing (#68)", { set.seed(680) n <- 20L; p <- 4L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) X[, 2] <- 3.5 # feature 2 is a CONSTANT column colnames(X) <- paste0("V", 1:p) y <- X[, 1] + stats::rnorm(n) # y correlated with feature 1 (varying) # feat_sel_mat: features 1 and 2 tie at selection proportion 0.5 (both # "selected" in the same 5 of 10 subsamples), forcing the tie-break path. B <- 10L M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L M[1:5, 2] <- 1L css_results <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # Pre-fix: cor(X[, c(1,2)], y) -> c(<corr>, NA) -> max NA -> stopifnot abort. proto <- getSelectionPrototypes(css_results, selected_clusts = list(c(1L, 2L))) testthat::expect_false(is.na(proto)) testthat::expect_identical(unname(proto), 1L) # the varying, y-correlated member # All-constant tied cluster: must not crash, picks the first deterministically. # (suppressWarnings: the names-assignment emits a pre-existing "number of items # to replace..." warning when proto_i stays length>1; not introduced by this # fix, unrelated to #68.) X2 <- X; X2[, 3] <- 2.0; X2[, 4] <- 9.0 M2 <- matrix(0L, nrow = B, ncol = p); M2[1:5, 3] <- 1L; M2[1:5, 4] <- 1L css2 <- structure(list(X = X2, y = y, feat_sel_mat = M2), class = "cssr") proto2 <- suppressWarnings( getSelectionPrototypes(css2, selected_clusts = list(c(3L, 4L)))) testthat::expect_identical(unname(proto2), 3L) }) testthat::test_that("getSelectionPrototypes skips the correlation tie-break for non-numeric y (#128)", { # css() accepts a non-numeric y (response validation is delegated to fitfun), # so getSelectionPrototypes must NOT call cor() -- which requires a numeric y -- # when breaking a selection-proportion tie. Hand-build a cssr object with a # CHARACTER y and a feat_sel_mat in which members 1 and 2 tie (equal column # means) so the tie block IS entered (length(proto_i) > 1). Without the # is.numeric(y) guard, cor(X[, 1:2], <character y>) would error; the guard skips # it and the first tied index is returned deterministically. B <- 10L; p <- 2L; n <- 8L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- paste0("V", 1:p) y <- letters[1:n] # non-numeric (character) response M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5, M[1:5, 2] <- 1L # forcing the tie-break path css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # suppressWarnings: an unbroken length-2 tie triggers a benign R "number of # items to replace" warning at the names-assignment (it fires for ANY persisted # tie, incl. the numeric #68 case) that would otherwise fail testthat edition 3. res <- suppressWarnings(getSelectionPrototypes(css, list(c(1L, 2L)))) testthat::expect_identical(unname(res), 1L) # first tied index, deterministic }) testthat::test_that("getSelectionPrototypes emits no warning on an unbroken tie (#126)", { # Item-5 regression (#126): the name-assignment now indexes proto_i[1] (a single # element), not the possibly length>1 proto_i. On an UNBROKEN within-cluster tie # -- here a CHARACTER y, so the numeric correlation tie-break is skipped and # proto_i stays length 2 -- the pre-fix code raised R's "number of items to # replace is not a multiple of replacement length" warning at the names<- # assignment (surfacing through print.cssr / summary.cssr / printCssDf). After # the fix NO warning fires, and the returned prototype is still the first tied # index (value unchanged; only the spurious warning is removed). B <- 10L; p <- 2L; n <- 8L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- paste0("V", 1:p) y <- letters[1:n] # non-numeric (character) response M <- matrix(0L, nrow = B, ncol = p) M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5, M[1:5, 2] <- 1L # forcing the (unbroken) tie-break path css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr") # No suppressWarnings here: the fix must make this call warning-free. testthat::expect_no_warning( res <- getSelectionPrototypes(css, list(c(1L, 2L)))) testthat::expect_identical(unname(res), 1L) # first tied index, deterministic testthat::expect_identical(names(res), "V1") # name taken from proto_i[1] only }) ## Test passed with 17 successes. ## Test passed with 3 successes. ## Test passed with 1 success. ## Test passed with 3 successes. Tests for printCssDf(): testthat::test_that("printCssDf works", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10) ret <- printCssDf(css_results) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_true(all(names(good_clusters) %in% ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) # Try again naming features x_named <- x colnames(x_named) <- LETTERS[1:11] css_results_name_feats <- css(X=x_named, y=y, lambda=0.01, clusters=good_clusters, B=10) ret <- printCssDf(css_results_name_feats) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_true(all(names(good_clusters) %in% ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.character(ret$ClustProtoName)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoName"] %in% LETTERS[1:3]) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoName"] %in% LETTERS[4:6]) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoName"] %in% LETTERS[7:11])) testthat::expect_true(length(ret[other_rows, "ClustProtoName"]) == length(unique(ret[other_rows, "ClustProtoName"]))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) # Unnamed clusters unnamed_clusters <- list(1:3, 4:6) css_results_unnamed <- css(X=x, y=y, lambda=0.01, clusters=unnamed_clusters, B=10) ret <- printCssDf(css_results_unnamed) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_equal(nrow(ret), 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) # Try other settings for cutoff, min_num_clusts, max_num_clusts, etc. ret <- printCssDf(css_results, max_num_clusts=3) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) testthat::expect_true(nrow(ret) <= 3) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } ret <- printCssDf(css_results, min_num_clusts=2, cutoff=1) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7 testthat::expect_true(nrow(ret) >= 2) testthat::expect_true(nrow(ret) <= 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } # ret <- printCssDf(css_results, cutoff=1) testthat::expect_true(is.data.frame(ret)) testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) testthat::expect_true(nrow(ret) >= 1) testthat::expect_true(nrow(ret) <= 7) testthat::expect_true(is.character(ret$ClustName)) testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName))) testthat::expect_true(is.integer(ret$ClustProtoNum)) other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster")) testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L)) testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) == length(unique(ret[other_rows, "ClustProtoNum"]))) testthat::expect_true(is.numeric(ret$ClustSelProp)) testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp, decreasing=TRUE)) testthat::expect_true(is.integer(ret$ClustSize)) testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1)) if("red_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="red_cluster", "ClustProtoNum"] %in% 1L:3L) testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3) } if("green_cluster" %in% ret$ClustName){ testthat::expect_true(ret[ret$ClustName=="green_cluster", "ClustProtoNum"] %in% 4L:6L) testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3) } ## Trying bad inputs # Error has quotation marks in it testthat::expect_error(printCssDf("css_results")) testthat::expect_error(printCssDf(css_results, cutoff=-.1), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(printCssDf(css_results, min_num_clusts=3.2), "min_num_clusts == round(min_num_clusts) is not TRUE", fixed=TRUE) testthat::expect_error(printCssDf(css_results, max_num_clusts="5"), "is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE", fixed=TRUE) }) ## Test passed with 98 successes. Tests for print.cssr() (and a minimal-B smoke test for css()): testthat::test_that("print.cssr 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) # print() dispatches to print.cssr, which returns its argument invisibly (the # standard print-method convention; see print.cssr's @return / #16). testthat::expect_invisible(print(css_res)) ret <- print(css_res) testthat::expect_identical(ret, css_res) # It prints the printCssDf summary table (column headers included). testthat::expect_output(print(css_res), "ClustName") testthat::expect_output(print(css_res), "ClustSize") # max_num_clusts routes through to printCssDf (at most that many cluster rows). out_all <- utils::capture.output(print(css_res)) out_one <- utils::capture.output(print(css_res, max_num_clusts=1)) testthat::expect_true(length(out_one) <= length(out_all)) }) testthat::test_that("css runs with B = 1 (minimal subsampling)", { 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) # B = 1 is allowed (checkB requires only B > 0) but warns that small B is poor. testthat::expect_warning( css_b1 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 1), "Small values of B may lead to poor results.", fixed=TRUE) testthat::expect_true(inherits(css_b1, "cssr")) # The minimal-B object is still well-formed downstream. sel <- getCssSelections(css_b1) testthat::expect_identical(names(sel), c("selected_clusts", "selected_feats", "weights")) }) ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 banana 4 1.00 2 ## 2 cantaloupe 5 0.80 1 ## 3 c4 6 0.60 1 ## 4 apple 1 0.55 2 ## 5 c5 7 0.30 1 ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 banana 4 1.00 2 ## 2 cantaloupe 5 0.80 1 ## 3 c4 6 0.60 1 ## 4 apple 1 0.55 2 ## 5 c5 7 0.30 1 ## Test passed with 5 successes. ## Test passed with 3 successes. Tests for selected() / selected.cssr(): testthat::test_that("selected.cssr returns clusters and features", { 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) ref <- getCssSelections(css_res) # type = "clusters" (the default): a named list of integer vectors, identical # to getCssSelections()$selected_clusts at the same parameters. clusts <- selected(css_res) testthat::expect_true(is.list(clusts)) testthat::expect_identical(clusts, ref$selected_clusts) testthat::expect_identical(selected(css_res, type="clusters"), ref$selected_clusts) # type = "features": a flat integer vector, identical to # getCssSelections()$selected_feats. feats <- selected(css_res, type="features") testthat::expect_true(is.integer(feats)) testthat::expect_identical(feats, ref$selected_feats) # S3 dispatch: selected(obj) reaches selected.cssr(). testthat::expect_identical(selected(css_res), selected.cssr(css_res)) # Consistency with getCssSelections() at a nondefault cutoff and weighting # (features path). ref2 <- getCssSelections(css_res, weighting="simple_avg", cutoff=0.3) testthat::expect_identical( selected(css_res, type="features", weighting="simple_avg", cutoff=0.3), ref2$selected_feats) # Invalid inputs are rejected via the reused checks (checkCutoff / # checkWeighting), same messages as getCssSelections(). testthat::expect_error(selected(css_res, cutoff=-0.5), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(selected(css_res, weighting="spasre"), "Weighting must be a character and one of sparse, simple_avg, or weighted_avg", fixed=TRUE) }) testthat::test_that("selected(type='clusters') is invariant to weighting", { 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) # weighting only affects individual-feature weights, never which clusters are # selected: the type = "clusters" output is identical across weighting values. sparse <- selected(css_res, type="clusters", weighting="sparse", cutoff=0.2) wavg <- selected(css_res, type="clusters", weighting="weighted_avg", cutoff=0.2) savg <- selected(css_res, type="clusters", weighting="simple_avg", cutoff=0.2) testthat::expect_identical(sparse, wavg) testthat::expect_identical(sparse, savg) # By contrast the features path CAN depend on weighting: "simple_avg" returns # every member of the selected clusters, so at least as many as "sparse". feats_sparse <- selected(css_res, type="features", weighting="sparse", cutoff=0.2) feats_savg <- selected(css_res, type="features", weighting="simple_avg", cutoff=0.2) testthat::expect_true(length(feats_savg) >= length(feats_sparse)) }) ## Test passed with 9 successes. ## Test passed with 3 successes. Tests for summary.cssr() / print.summary.cssr(): testthat::test_that("summary.cssr summarizes clusters, sizes, and header counts", { set.seed(67234) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6)) x <- data$X y <- data$y good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L) css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10) smry <- summary(css_res) testthat::expect_true(inherits(smry, "summary.cssr")) ref <- getCssSelections(css_res) ref_df <- printCssDf(css_res) # Header counts are consistent with getCssSelections(). testthat::expect_equal(smry$n_selected_clusts, length(ref$selected_clusts)) testthat::expect_equal(smry$n_selected_feats, length(ref$selected_feats)) testthat::expect_equal(smry$cutoff, 0) # The per-cluster table IS printCssDf()'s data.frame (Theta-hat = ClustSelProp, # plus ClustSize), so clusters / proportions / sizes all match. testthat::expect_identical(smry$table, ref_df) testthat::expect_equal(nrow(smry$table), 7) testthat::expect_equal(smry$n_selected_clusts, nrow(smry$table)) testthat::expect_true(all(c("ClustName", "ClustSelProp", "ClustSize") %in% colnames(smry$table))) testthat::expect_equal(smry$table[smry$table$ClustName=="red_cluster", "ClustSize"], 3) testthat::expect_equal(smry$table[smry$table$ClustName=="green_cluster", "ClustSize"], 3) # PFER placeholder present (to be filled in by #87). testthat::expect_true("pfer" %in% names(smry)) testthat::expect_true(is.na(smry$pfer)) # print.summary.cssr runs, prints the header + table, returns x invisibly. testthat::expect_invisible(print(smry)) ret <- print(smry) testthat::expect_identical(ret, smry) testthat::expect_output(print(smry), "selected at cutoff") testthat::expect_output(print(smry), "ClustName") # S3 dispatch: summary(obj) reaches summary.cssr(). testthat::expect_identical(summary(css_res), summary.cssr(css_res)) # Invalid cutoff rejected via the reused check. testthat::expect_error(summary(css_res, cutoff=1.5), "cutoff <= 1 is not TRUE", fixed=TRUE) }) ## Cluster stability selection summary ## 7 clusters / 7 features selected at cutoff 0 ## ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 red_cluster 1 1.00 3 ## 2 c3 7 1.00 1 ## 3 green_cluster 6 0.80 3 ## 4 c7 11 0.70 1 ## 5 c6 10 0.65 1 ## 6 c4 8 0.60 1 ## 7 c5 9 0.40 1 ## ## PFER: NA (not yet implemented; see issue #87) ## Cluster stability selection summary ## 7 clusters / 7 features selected at cutoff 0 ## ## ClustName ClustProtoNum ClustSelProp ClustSize ## 1 red_cluster 1 1.00 3 ## 2 c3 7 1.00 1 ## 3 green_cluster 6 0.80 3 ## 4 c7 11 0.70 1 ## 5 c6 10 0.65 1 ## 6 c4 8 0.60 1 ## 7 c5 9 0.40 1 ## ## PFER: NA (not yet implemented; see issue #87) ## Test passed with 18 successes. Test for the empty-selection path of the print layer (issues #107 and #120). Post-#107 an empty selection is valid; #120 makes printCssDf(), print.cssr(), and getSelectionPrototypes() return clean empty output – a zero-row data.frame, a “(no clusters selected …)” message, and an empty integer vector, respectively – via an early return before the nrow >= 1 / n_selected_clusts >= 1 guards, rather than tripping those assertions. The block also covers the higher-level selected() and a zero-row summary.cssr(). testthat::test_that("selected() and summary() handle an empty selection", { # Same empty-producing fixture as the getCssSelections #107 test: fixed seed, # all-singleton clusters, and a large lambda so the base lasso selects almost # nothing; cutoff = 1 with min_num_clusts = 0 then selects no cluster. 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)) # selected(): a clean empty list / empty integer vector, no error. empty_clusts <- selected(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(is.list(empty_clusts)) testthat::expect_length(empty_clusts, 0) empty_feats <- selected(css_res, type="features", cutoff=1, min_num_clusts=0) testthat::expect_true(is.integer(empty_feats)) testthat::expect_length(empty_feats, 0) # summary(): a well-formed zero-row summary (table NULL, "0 clusters" header), # NOT an opaque stopifnot() failure from printCssDf/getSelectionPrototypes. smry <- summary(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(inherits(smry, "summary.cssr")) testthat::expect_equal(smry$n_selected_clusts, 0) testthat::expect_equal(smry$n_selected_feats, 0) testthat::expect_true(is.null(smry$table)) # print still works and reports 0 clusters / 0 features. testthat::expect_invisible(print(smry)) testthat::expect_output(print(smry), "0 clusters / 0 features") # printCssDf() (#120): an empty selection returns a well-formed zero-row # data.frame with the SAME columns as a non-empty printCssDf() on the same # object, rather than tripping stopifnot(nrow >= 1). Unnamed X (this fixture) # -> 4 columns, no ClustProtoName. empty_df <- printCssDf(css_res, cutoff=1, min_num_clusts=0) testthat::expect_true(is.data.frame(empty_df)) testthat::expect_equal(nrow(empty_df), 0) testthat::expect_equal(ncol(empty_df), 4) nonempty_df <- printCssDf(css_res, cutoff=0) testthat::expect_true(nrow(nonempty_df) >= 1) # The invariant that matters: empty and non-empty share the same column set. testthat::expect_identical(colnames(empty_df), colnames(nonempty_df)) testthat::expect_identical( colnames(empty_df), c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize")) # Correct 0-length column types. testthat::expect_true(is.character(empty_df$ClustName)) testthat::expect_true(is.integer(empty_df$ClustProtoNum)) testthat::expect_true(is.numeric(empty_df$ClustSelProp)) testthat::expect_true(is.integer(empty_df$ClustSize)) # Named X -> the 5-column path (adds ClustProtoName). Same data + column names, # so the selection is still empty at cutoff = 1 with min_num_clusts = 0. x_named <- x colnames(x_named) <- paste0("V", seq_len(ncol(x_named))) css_named <- css(X=x_named, y=y, lambda=0.5, clusters=list(), B=B) empty_named_df <- printCssDf(css_named, cutoff=1, min_num_clusts=0) testthat::expect_true(is.data.frame(empty_named_df)) testthat::expect_equal(nrow(empty_named_df), 0) testthat::expect_equal(ncol(empty_named_df), 5) testthat::expect_true("ClustProtoName" %in% colnames(empty_named_df)) testthat::expect_identical(colnames(empty_named_df), colnames(printCssDf(css_named, cutoff=0))) # getSelectionPrototypes() on an empty list of clusters -> integer(0) (#120). testthat::expect_identical(getSelectionPrototypes(css_res, list()), integer(0)) # print.cssr() (#120): prints a "(no clusters selected ...)" message instead # of a table, does not error, and returns the cssr object invisibly unchanged. testthat::expect_output( ret <- print(css_res, cutoff=1, min_num_clusts=0), "no clusters selected") testthat::expect_identical(ret, css_res) testthat::expect_invisible(print(css_res, cutoff=1, min_num_clusts=0)) }) ## Cluster stability selection summary ## 0 clusters / 0 features selected at cutoff 1 ## (no clusters selected at this cutoff) ## ## PFER: NA (not yet implemented; see issue #87) ## (no clusters selected at cutoff 1) ## Test passed with 30 successes. Tests for plot.cssr(). All plotting is drawn to a null device (grDevices::pdf(NULL) / grDevices::dev.off()) so the tests produce no file or window. They cover the return value (the sorted selection proportions), the index-based feature highlight for an unnamed X (the B2 guard), ... passthrough to barplot() without a duplicate-argument crash (the B1 guard), and the empty-selection and single-cluster edge cases. testthat::test_that("plot.cssr draws cluster proportions and returns them sorted", { # Named X so the feature matrix (tested below) carries feature names. set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) grDevices::pdf(NULL) # draw to a null device (no file, no window) # (a) Clusters (default): runs without error and invisibly returns the sorted # named cluster selection proportions (a deterministic proof of the return). testthat::expect_invisible(plot(css_res)) ret <- plot(css_res) testthat::expect_equal(ret, sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE)) testthat::expect_false(is.null(names(ret))) # cluster names guaranteed # (b) Features, NAMED X: returns the sorted NAMED feature selection # proportions, and the (index-based) highlight matches getCssSelections(). ret_f <- plot(css_res, type="features") props_f <- colMeans(css_res$feat_sel_mat) testthat::expect_equal(ret_f, sort(props_f, decreasing=TRUE)) testthat::expect_identical(names(ret_f), paste0("V", order(props_f, decreasing=TRUE))) # named + correctly ordered sel_f <- getCssSelections(css_res, weighting="sparse") ord <- order(props_f, decreasing=TRUE) is_sel <- (seq_along(props_f) %in% as.integer(sel_f$selected_feats))[ord] testthat::expect_equal(sum(is_sel), length(sel_f$selected_feats)) testthat::expect_setequal(ord[is_sel], as.integer(sel_f$selected_feats)) grDevices::dev.off() }) testthat::test_that("plot.cssr feature highlight is index-based for unnamed X (B2)", { # genClusteredData returns X with NULL colnames -> feat_sel_mat is UNNAMED. # A name-based feature highlight would silently be all-FALSE; the method uses # an INDEX-based highlight, which must still be non-empty. This is the B2 # regression proof. set.seed(721) dat <- genClusteredData(n=60, p=11, k_unclustered=2, cluster_size=4, n_clusters=1, snr=3) clusters <- list(cluster1=1:4) css_res <- suppressWarnings(css(X=dat$X, y=dat$y, lambda=0.01, clusters=clusters, B=10)) # Precondition for the B2 guard: the feature matrix really is unnamed. testthat::expect_null(colnames(css_res$feat_sel_mat)) grDevices::pdf(NULL) props <- colMeans(css_res$feat_sel_mat) ret <- plot(css_res, type="features", cutoff=0.3) # Returns the plain (unnamed) sorted colMeans regardless of the cutoff. testthat::expect_equal(ret, sort(props, decreasing=TRUE)) testthat::expect_null(names(ret)) # Re-derive the highlight exactly as plot.cssr does: INDEX-based. sel <- getCssSelections(css_res, weighting="sparse", cutoff=0.3) testthat::expect_true(length(sel$selected_feats) > 0) # there ARE selections ord <- order(props, decreasing=TRUE) is_sel <- (seq_along(props) %in% as.integer(sel$selected_feats))[ord] testthat::expect_true(any(is_sel)) # NON-empty highlight testthat::expect_equal(sum(is_sel), length(sel$selected_feats)) # The highlighted bars are exactly the selected features, by ORIGINAL index. testthat::expect_setequal(ord[is_sel], as.integer(sel$selected_feats)) # Contrast: a NAME-based highlight WOULD have failed here (names are NULL, so # names(props) %in% ... is logical(0) -> no bar highlighted). testthat::expect_false(any(names(props) %in% as.character(sel$selected_feats))) grDevices::dev.off() }) testthat::test_that("plot.cssr forwards ... to barplot without a duplicate-arg crash (B1)", { # The method builds a SINGLE merged barplot arg list, so graphical params on # ... cannot collide with col/ylim/height (which previously crashed with # "formal argument 'col' matched by multiple actual arguments"). set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) grDevices::pdf(NULL) testthat::expect_no_error(plot(css_res, col="red")) testthat::expect_no_error(plot(css_res, ylim=c(0, 0.5))) testthat::expect_no_error(plot(css_res, main="x")) testthat::expect_no_error(plot(css_res, type="features", col="red", main="feats")) grDevices::dev.off() }) testthat::test_that("plot.cssr handles an empty selection and a single cluster", { # (e) Empty selection: min_num_clusts = 0 with a cutoff strictly above every # cluster proportion selects nothing (min_num_clusts = 1 is never empty). All # bars get unsel_col, there is no highlight, and there is no crash. 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) max_prop <- max(colMeans(css_res$clus_sel_mat)) testthat::expect_true(max_prop < 1) cut <- (max_prop + 1) / 2 # strictly between max_prop and 1 (and <= 1) sel <- getCssSelections(css_res, cutoff=cut, min_num_clusts=0) testthat::expect_length(sel$selected_clusts, 0) # genuinely empty grDevices::pdf(NULL) # A bare call that errored would fail the test -> this asserts "no crash". ret <- plot(css_res, min_num_clusts=0, cutoff=cut) testthat::expect_equal(ret, sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE)) grDevices::dev.off() # (f) Single-cluster css: clus_sel_mat has exactly one column -> a length-1 # barplot, no error. set.seed(1) x1 <- matrix(stats::rnorm(10*4), nrow=10, ncol=4) y1 <- stats::rnorm(10) css_1 <- css(X=x1, y=y1, lambda=0.01, clusters=list(all=1:4), B=10) testthat::expect_equal(ncol(css_1$clus_sel_mat), 1) grDevices::pdf(NULL) ret1 <- plot(css_1) testthat::expect_length(ret1, 1) grDevices::dev.off() }) testthat::test_that("plot.cssr surfaces the tie-breach warning (#159c)", { # plot.cssr no longer wraps getCssSelections in suppressWarnings, so a # max_num_clusts breach reaches the user. Two clusters tied at proportion 1.0 # with max_num_clusts = 1 cannot be reduced below 2 without emptying the # selection, so checkSelectedClusters warns. Pre-#159c the blanket # suppressWarnings swallowed it, so this test FAILS on the old code. B <- 10 clusters <- list(c1 = 1L, c2 = 2L) clus_sel_mat <- cbind(c1 = rep(1L, B), c2 = rep(1L, B)) feat_sel_mat <- cbind(f1 = rep(1L, B), f2 = rep(1L, B)) obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat, clusters = clusters), class = "cssr") grDevices::pdf(NULL) # draw to a null device (no file, no window) on.exit(grDevices::dev.off(), add = TRUE) testthat::expect_warning(plot(obj, max_num_clusts = 1), "Returning more than max_num_clusts", fixed = TRUE) }) ## Test passed with 7 successes. ## Test passed with 8 successes. ## Test passed with 4 successes. ## Test passed with 5 successes. ## Test passed with 1 success. Two further tests pin down the issue #160 fixes. Both mock the graphics drawing primitives with testthat::with_mocked_bindings() so they can assert on the arguments the method actually passes to them. The first checks that a user-supplied col in ... now reaches barplot() verbatim – and that, with no col, the method’s own highlight colors still apply. The second checks that the dashed cutoff line is drawn only for type = \"clusters\" (whose axis matches the highlight) and never for type = \"features\". testthat::test_that("plot.cssr honors a user col in ... and otherwise applies the highlight (#160a)", { set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) # barplot is mocked (nothing is drawn) and cutoff = 0 (no abline), so no real # graphics call is made; the device is opened only defensively. grDevices::pdf(NULL) on.exit(grDevices::dev.off(), add=TRUE) # (a1) A user col in ... must reach barplot() verbatim. Before #160a the method # overwrote it with the highlight colors (this asserted "red" but got # steelblue/grey70). captured <- NULL testthat::with_mocked_bindings( barplot = function(...) captured <<- list(...), plot(css_res, col="red"), .package = "graphics" ) testthat::expect_identical(captured$col, "red") # (a2) With no col the method's own highlight must STILL apply -- guards against # over-fixing (a1) by dropping the default. max_num_clusts=2 forces a genuine # mix (>=1 selected, >=1 unselected) so both ifelse branches are exercised. captured2 <- NULL testthat::with_mocked_bindings( barplot = function(...) captured2 <<- list(...), plot(css_res, max_num_clusts=2), .package = "graphics" ) props <- colMeans(css_res$clus_sel_mat) sel <- suppressWarnings(getCssSelections(css_res, weighting="sparse", cutoff=0, min_num_clusts=1, max_num_clusts=2)) is_sel <- (names(props) %in% names(sel$selected_clusts))[order(props, decreasing=TRUE)] testthat::expect_identical(captured2$col, ifelse(is_sel, "steelblue", "grey70")) testthat::expect_true("steelblue" %in% captured2$col) # a genuine mix, so both testthat::expect_true("grey70" %in% captured2$col) # branches are covered }) testthat::test_that("plot.cssr draws the cutoff line only for type='clusters' (#160b)", { set.seed(26717) x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7) colnames(x) <- paste0("V", seq_len(ncol(x))) 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) # Real barplot draws to a null device; only abline is mocked (a flag/capture). grDevices::pdf(NULL) on.exit(grDevices::dev.off(), add=TRUE) # (b1) type="features": the line would sit on the feature-proportion axis while # highlighting follows cluster selection, so no reference line is drawn (#160b). called <- FALSE testthat::with_mocked_bindings( abline = function(...) called <<- TRUE, plot(css_res, type="features", cutoff=0.6), .package = "graphics" ) testthat::expect_false(called) # (b2) type="clusters": the line's axis matches the highlight, so it IS drawn at # h = cutoff. called <- FALSE ab_args <- NULL testthat::with_mocked_bindings( abline = function(...) { called <<- TRUE; ab_args <<- list(...) }, plot(css_res, type="clusters", cutoff=0.6), .package = "graphics" ) testthat::expect_true(called) testthat::expect_equal(ab_args$h, 0.6) # (b3) cutoff=0: no line in either mode (unchanged behavior). called <- FALSE testthat::with_mocked_bindings( abline = function(...) called <<- TRUE, plot(css_res, type="clusters", cutoff=0), .package = "graphics" ) testthat::expect_false(called) }) ## Test passed with 4 successes. ## Test passed with 4 successes. Byte-identity tests for the issue #129 performance micro-optimizations. Each asserts that the de-duplicated / hoisted path returns a value identical to the recomputed path it replaced. Per issue #129 these compare RETURN VALUES (wrapped in suppressWarnings), never warning counts: Opts 2 and 3 intentionally collapse repeated getSelectedClusters() calls, which only de-duplicates a warning side-channel and leaves the returned objects unchanged. testthat::test_that("Opt 2 (#129): formCssDesign weights= equals internal recompute; getCssPreds finite", { set.seed(721) dat <- genClusteredData(n = 60, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) clusters <- list(cluster1 = 1:4) res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 15)) # The hoist: passing weights= (as getCssPreds now does) must build a design # matrix byte-identical to letting formCssDesign() recompute the weights via # getSelectedClusters(), across every weighting rule. for(w in c("sparse", "weighted_avg", "simple_avg")){ wts <- getSelectedClusters(res, w, 0, 1, NA)$weights d_recompute <- suppressWarnings(formCssDesign(res, weighting = w, newx = dat$X)) d_passed <- suppressWarnings(formCssDesign(res, weighting = w, newx = dat$X, weights = wts)) testthat::expect_identical(d_passed, d_recompute) } # End-to-end getCssPreds still returns finite predictions of the right length # for both the provided-trainX path and the train_inds path, across weightings. res_ti <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 15, train_inds = 41:60)) for(w in c("sparse", "weighted_avg", "simple_avg")){ p_prov <- suppressWarnings(getCssPreds(res, testX = dat$X[1:10, ], trainX = dat$X[11:40, ], trainY = dat$y[11:40], weighting = w)) testthat::expect_length(p_prov, 10) testthat::expect_true(all(is.finite(p_prov))) p_ti <- suppressWarnings(getCssPreds(res_ti, testX = dat$X[1:10, ], weighting = w)) testthat::expect_length(p_ti, 10) testthat::expect_true(all(is.finite(p_ti))) } }) testthat::test_that("Opt 3 (#129): buildCssDf equals printCssDf; summary$table reuses it", { set.seed(824) dat <- genClusteredData(n = 55, p = 11, k_unclustered = 2, cluster_size = 4, n_clusters = 1, snr = 3) clusters <- list(cluster1 = 1:4) res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01, clusters = clusters, B = 12)) # buildCssDf(obj, getCssSelections(obj, ...)$selected_clusts) reproduces # printCssDf(obj, ...) exactly, across cutoffs (including the empty selection # at cutoff = 1 with min_num_clusts = 0). for(cut in c(0, 0.2, 0.5, 1)){ sc <- suppressWarnings(getCssSelections(res, cutoff = cut, min_num_clusts = 0))$selected_clusts testthat::expect_identical( suppressWarnings(buildCssDf(res, sc)), suppressWarnings(printCssDf(res, cutoff = cut, min_num_clusts = 0))) } # summary.cssr()$table (now built via buildCssDf() on summary's own # sel$selected_clusts) equals printCssDf() on the same object across # weightings -- cluster selection is weighting-invariant, so reusing summary's # sel$selected_clusts is byte-identical to printCssDf's internal recompute. ref <- suppressWarnings(printCssDf(res)) for(w in c("sparse", "weighted_avg", "simple_avg")){ s <- suppressWarnings(summary(res, weighting = w)) testthat::expect_identical(s$table, ref) } }) ## Test passed with 15 successes. ## Test passed with 7 successes. "],["tests-for-wrapper-functions.html", "11 Tests for wrapper functions", " 11 Tests for wrapper functions Tests for cssSelect(): testthat::test_that("cssSelect works", { set.seed(73212) data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1) x <- data$X y <- data$y # Intentionally don't provide clusters for all features, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:3L, 4:6) res <- cssSelect(X=x, y=y, clusters=good_clusters) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_true(length(res$selected_clusts) <= 7) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # No provided clusters res <- cssSelect(X=x, y=y) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) testthat::expect_true(length(res$selected_clusts) <= 11) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars # cssSelect() reports a max_num_clusts tie on this draw. It is not asserted, # because whether the tie occurs depends on the estimated model size and so # on glmnet's lasso path rather than on cssr; the warning has deterministic # coverage in "checkSelectedClusters works" and in the #159c plot.cssr test. # Muffling just that one message leaves every other warning visible (#186). res <- withCallingHandlers( cssSelect(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3), warning = function(w) { if (grepl("Returning more than max_num_clusts", conditionMessage(w), fixed = TRUE)) { invokeRestart("muffleWarning") } }) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of ncol(X_df) - (3 - 1) clusters testthat::expect_true(length(res$selected_clusts) <= ncol(X_df) - 2) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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:ncol(X_df))) 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) <= ncol(X_df)) testthat::expect_equal(length(already_used_feats), length(unique(already_used_feats))) testthat::expect_true(all(already_used_feats %in% 1:ncol(X_df))) testthat::expect_true(length(res$selected_feats) <= ncol(X_df)) 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 <= ncol(X_df))) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if I try to use data.frame with clusters, since data.frame # has factors with more than two levels testthat::expect_error(cssSelect(X=df2, y=stats::rnorm(nrow(X_df)), clusters=1:3), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert the data.frame X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if I don't use clusters res <- cssSelect(X=df2, y=stats::rnorm(nrow(X_df))) X_df_mat <- stats::model.matrix(~ ., df2) X_df_mat <- X_df_mat[, colnames(X_df_mat) != "(Intercept)"] p <- ncol(X_df_mat) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of p - (3 - 1) clusters testthat::expect_true(length(res$selected_clusts) <= p - 2) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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:p)) 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) <= p) testthat::expect_equal(length(already_used_feats), length(unique(already_used_feats))) testthat::expect_true(all(already_used_feats %in% 1:p)) testthat::expect_true(length(res$selected_feats) <= p) 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 <= p)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] res <- cssSelect(X=x2, y=y, clusters=good_clusters) 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(!is.null(names(res$selected_clusts))) testthat::expect_true(is.character(names(res$selected_clusts))) testthat::expect_true(length(res$selected_clusts) <= length(res$selected_feats)) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_true(length(res$selected_clusts) <= 7) testthat::expect_true(length(res$selected_clusts) >= 1) testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11)) testthat::expect_equal(length(res$selected_feats), length(unique(res$selected_feats))) # Vary inputs res <- cssSelect(X=x, y=y, clusters=good_clusters, lambda=0.01) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) res <- cssSelect(X=x, y=y, clusters=good_clusters, cutoff=0.6) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) res <- cssSelect(X=x, y=y, clusters=good_clusters, max_num_clusts=6) 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) <= 6) res <- cssSelect(X=x, y=y, clusters=good_clusters, auto_select_size=FALSE) testthat::expect_true(is.list(res)) testthat::expect_equal(length(res), 3) testthat::expect_identical(names(res), c("selected_clusts", "selected_feats", "weights")) # Total of 11 - 2*(3 - 1) = 7 clusters testthat::expect_equal(length(res$selected_clusts), 7) # Bad inputs testthat::expect_error(cssSelect(X=x[1:10, ], y=y), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=character(5), y=y), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=matrix(1:15, 5, 3)), "!is.matrix(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=factor(rbinom(15, size=1, prob=.5))), "The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, clusters="clusters"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, lambda=-.1), "For method cssLasso, lambda must be nonnegative.", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, cutoff=1.1), "cutoff <= 1 is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, max_num_clusts=1000), "max_num_clusts <= p is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, auto_select_size=1), "is.logical(auto_select_size) is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(cssSelect(X=x, y=y, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(cssSelect(X=x, y=y, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) # alpha = NA is rejected with a clear message (rather than a cryptic error # deep inside the bundling/subsampling logic). A bare (logical) NA trips the # type check first; a numeric NA reaches the dedicated !is.na guard. testthat::expect_error(cssSelect(X=x, y=y, alpha=NA), "is.numeric(alpha) | is.integer(alpha) is not TRUE", fixed=TRUE) testthat::expect_error(cssSelect(X=x, y=y, alpha=NA_real_), "!is.na(alpha) is not TRUE", fixed=TRUE) # An NA in the design matrix yields the shared friendly message (#56). x_na <- x; x_na[2, 1] <- NA testthat::expect_error(cssSelect(X=x_na, y=y), "must not contain missing", fixed=TRUE) # (#127) A single-column X reaches getLassoLambda as a matrix and now errors # with the clean "p >= 2 is not TRUE" message rather than a cryptic downstream # failure ("invalid 'times' argument"). testthat::expect_error( cssSelect(matrix(stats::rnorm(40), nrow=40, ncol=1), stats::rnorm(40)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 220 successes. Tests confirming that a non-default alpha is threaded through cssSelect() end-to-end and changes the selected set on a correlated-block design (this is the wrapper-level analogue of the cssLasso headline test; it is new behavior absent on main, where alpha could not affect selection): testthat::test_that("cssSelect threads alpha through to selection", { set.seed(1) n <- 100 p <- 20 rho <- 0.9 block <- 4 Z <- matrix(stats::rnorm(n*p), n, p) common <- stats::rnorm(n) for(j in 1:block){ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j] } y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n)) # Treat the correlated block as one cluster; the remaining features are # singletons. Fix lambda and the model size so the only thing that varies # between the two calls is alpha. clusters <- list(block=1:block) res_lasso <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251, max_num_clusts=p - block + 1, alpha=1) res_enet <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251, max_num_clusts=p - block + 1, alpha=0.5) # Both return a well-formed selection for(res in list(res_lasso, res_enet)){ testthat::expect_true(is.list(res)) testthat::expect_true(all(c("selected_clusts", "selected_feats") %in% names(res))) testthat::expect_true(is.integer(res$selected_feats)) testthat::expect_true(all(res$selected_feats %in% 1:p)) } # The elastic net selects (weakly) more features than the pure lasso on this # correlated design, and the two selected sets differ. testthat::expect_true(length(res_enet$selected_feats) >= length(res_lasso$selected_feats)) testthat::expect_false(setequal(res_enet$selected_feats, res_lasso$selected_feats)) }) ## Test passed with 10 successes. Tests for cssPredict(): testthat::test_that("cssPredict works", { set.seed(84231) train_data <- genClusteredData(n=30, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1) x <- train_data$X y <- train_data$y test_x <- genClusteredData(n=5, p=11, k_unclustered=2, cluster_size=3, n_clusters=2, sig_clusters=1, sigma_eps_sq=1)$X # Intentionally don't provide clusters for all features, mix up formatting, # etc. good_clusters <- list(red_cluster=1L:3L, 4:6) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters=good_clusters) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # No provided clusters res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Provide training indices res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, train_inds=13:28) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) ## Trying other inputs # X as a data.frame X_df <- datasets::mtcars n <- nrow(X_df) test_inds <- 1:round(n/3) n_test <- length(test_inds) selec_train_inds <- setdiff(1:n, test_inds) n_selec_train <- length(selec_train_inds) res <- cssPredict(X_train_selec=X_df[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=X_df[test_inds, ]) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), n_test) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if clusters are provided because df2 contains factors with # more than two levels testthat::expect_error(cssPredict(X_train_selec=df2[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=df2[test_inds, ], clusters=1:3), "When stats::model.matrix converted the provided data.frame X_train_selec to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X_train_selec to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- cssPredict(X_train_selec=df2[selec_train_inds, ], y_train_selec=stats::rnorm(n_selec_train), X_test=df2[test_inds, ]) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), n_test) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] test_x2 <- test_x colnames(test_x2) <- LETTERS[1:11] res <- cssPredict(X_train_selec=x2, y_train_selec=y, X_test=test_x2, clusters=good_clusters) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Vary inputs res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, lambda=0.01) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=0.6) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, max_num_clusts=6) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, auto_select_size=FALSE) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Non-default alpha (elastic net) threaded through end-to-end; smoke test # confirming it returns a well-formed prediction vector of the right length. res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=0.5) testthat::expect_true(all(!is.na(res))) testthat::expect_true(is.numeric(res)) testthat::expect_equal(length(res), 5) # Bad inputs testthat::expect_error(cssPredict(X_train_selec=x[1:10, ], y_train_selec=y, X_test=test_x), "length(y) == n is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=character(30), y_train_selec=y, X_test=test_x), "is.matrix(X_train_selec) | is.data.frame(X_train_selec) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=matrix(1:30, 10, 3), X_test=test_x), "!is.matrix(y) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=factor(rbinom(30, size=1, prob=.5)), X_test=test_x), "The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, clusters="clusters"), "is.numeric(clusters) | is.integer(clusters) is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, lambda="lambda"), "For method cssLasso, lambda must be a numeric.", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=-.1), "cutoff >= 0 is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, max_num_clusts=0), "max_num_clusts >= 1 is not TRUE", fixed=TRUE) testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, auto_select_size=c(TRUE, FALSE)), "length(auto_select_size) == 1 is not TRUE", fixed=TRUE) # alpha = 0 (degenerate ridge) is rejected testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=0), "alpha > 0 is not TRUE", fixed=TRUE) # alpha > 1 is rejected testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, alpha=1.5), "alpha <= 1 is not TRUE", fixed=TRUE) # (#127) A single-column training design now reaches getLassoLambda as a matrix # (drop = FALSE on the subsample) and errors with the clean "p >= 2 is not # TRUE" message rather than "is.matrix(X) is not TRUE". testthat::expect_error( cssPredict(X_train_selec=matrix(stats::rnorm(40), nrow=40, ncol=1), y_train_selec=stats::rnorm(40), X_test=matrix(stats::rnorm(10), nrow=10, ncol=1)), "p >= 2 is not TRUE", fixed=TRUE) }) ## Test passed with 46 successes. A length-1 train_inds used to collapse X_train_selec[train_inds, ] to a vector, tripping getModelSize’s cryptic is.matrix(X) | is.data.frame(X) assertion. With drop = FALSE it stays a one-row matrix and the error instead points informatively at the data (issue #153, item f). testthat::test_that("cssPredict: length-1 train_inds no longer hits the cryptic is.matrix assertion (#153f)", { 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) # A length-1 train_inds leaves a single training row, so getModelSize's glmnet # cross-validation fails informatively on a constant response -- NOT with the # old cryptic is.matrix stopifnot from the dropped-to-vector subset. Warnings # (e.g. glmnet convergence) are suppressed so we assert on the stop() message. err <- tryCatch( suppressWarnings( cssPredict(X_train_selec = X[1:20, ], y_train_selec = y[1:20], X_test = X[41:60, ], clusters = clusters, lambda = 0.01, train_inds = 1L)), error = function(e) conditionMessage(e)) testthat::expect_type(err, "character") testthat::expect_true( grepl("y is constant; gaussian glmnet fails at standardization step", err, fixed = TRUE)) testthat::expect_false( grepl("is.matrix(X) | is.data.frame(X) is not TRUE", err, fixed = TRUE)) }) ## Test passed with 3 successes. "],["tests-for-competitor-methods.html", "12 Tests for competitor methods", " 12 Tests for competitor methods Tests for processClusterLassoInputs(): testthat::test_that("processClusterLassoInputs works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) ret <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("x", "clusters", "prototypes", "var_names")) # X testthat::expect_true(is.matrix(ret$x)) testthat::expect_true(all(!is.na(ret$x))) testthat::expect_true(is.numeric(ret$x)) testthat::expect_equal(ncol(ret$x), 11) testthat::expect_equal(nrow(ret$x), 15) testthat::expect_true(all(abs(ret$x - x) < 10^(-9))) # clusters testthat::expect_true(is.list(ret$clusters)) testthat::expect_equal(length(ret$clusters), 5) testthat::expect_equal(5, length(names(ret$clusters))) testthat::expect_equal(5, length(unique(names(ret$clusters)))) testthat::expect_true("red_cluster" %in% names(ret$clusters)) testthat::expect_true("green_cluster" %in% names(ret$clusters)) testthat::expect_true(all(!is.na(names(ret$clusters)))) testthat::expect_true(all(!is.null(names(ret$clusters)))) testthat::expect_true(all(names(ret$clusters) != "")) clust_feats <- integer() true_list <- list(1:4, 5:8, 9, 10, 11) for(i in 1:length(ret$clusters)){ testthat::expect_true(is.integer(ret$clusters[[i]])) testthat::expect_equal(length(intersect(clust_feats, ret$clusters[[i]])), 0) testthat::expect_true(all(ret$clusters[[i]] %in% 1:11)) testthat::expect_equal(length(ret$clusters[[i]]), length(unique(ret$clusters[[i]]))) testthat::expect_true(all(ret$clusters[[i]] == true_list[[i]])) clust_feats <- c(clust_feats, ret$clusters[[i]]) } testthat::expect_equal(length(clust_feats), 11) testthat::expect_equal(11, length(unique(clust_feats))) testthat::expect_equal(11, length(intersect(clust_feats, 1:11))) # prototypes testthat::expect_true(is.integer(ret$prototypes)) testthat::expect_true(all(ret$prototypes %in% 1:11)) testthat::expect_equal(length(ret$prototypes), 5) testthat::expect_true(ret$prototypes[1] %in% 1:4) testthat::expect_true(ret$prototypes[2] %in% 5:8) testthat::expect_equal(ret$prototypes[3], 9) testthat::expect_equal(ret$prototypes[4], 10) testthat::expect_equal(ret$prototypes[5], 11) # var_names testthat::expect_equal(length(ret$var_names), 1) testthat::expect_true(is.na(ret$var_names)) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("x", "clusters", "prototypes", "var_names")) X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # X testthat::expect_true(is.matrix(res$x)) testthat::expect_true(all(!is.na(res$x))) testthat::expect_true(is.numeric(res$x)) testthat::expect_equal(ncol(res$x), ncol(X_df_model)) testthat::expect_equal(nrow(res$x), nrow(X_df)) testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9))) # var_names testthat::expect_equal(length(res$var_names), ncol(X_df_model)) testthat::expect_true(is.character(res$var_names)) testthat::expect_identical(res$var_names, colnames(X_df_model)) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get error if I try to use clusters because df2 contains factors with # more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine with no clusters res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("x", "clusters", "prototypes", "var_names")) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # X testthat::expect_true(is.matrix(res$x)) testthat::expect_true(all(!is.na(res$x))) testthat::expect_true(is.numeric(res$x)) testthat::expect_equal(ncol(res$x), ncol(X_df_model)) testthat::expect_equal(nrow(res$x), nrow(X_df)) testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9))) # var_names testthat::expect_equal(length(res$var_names), ncol(X_df_model)) testthat::expect_true(is.character(res$var_names)) testthat::expect_identical(res$var_names, colnames(X_df_model)) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) testthat::expect_true(is.list(ret)) testthat::expect_identical(names(ret), c("x", "clusters", "prototypes", "var_names")) # X testthat::expect_true(is.matrix(ret$x)) testthat::expect_true(all(!is.na(ret$x))) testthat::expect_true(is.numeric(ret$x)) testthat::expect_equal(ncol(ret$x), 11) testthat::expect_equal(nrow(ret$x), 15) testthat::expect_true(all(abs(ret$x - x) < 10^(-9))) # var_names testthat::expect_equal(length(ret$var_names), ncol(x2)) testthat::expect_true(is.character(ret$var_names)) testthat::expect_identical(ret$var_names, LETTERS[1:11]) # Bad inputs testthat::expect_error(processClusterLassoInputs(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156): identical to passing the # cluster once (processClusterLassoInputs is deterministic here). testthat::expect_identical(processClusterLassoInputs(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10), processClusterLassoInputs(X=x, y=y, clusters=list(2:3), nlambda=10)) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) }) ## Test passed with 99 successes. Tests for checkGetXglmnetInputs(): testthat::test_that("checkGetXglmnetInputs works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get an error if clusters are provided since df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) checkGetXglmnetInputs(x=ret$x, clusters=ret$clusters, type="clusterRepLasso", prototypes=ret$prototypes) # Bad prototype inputs # Error has quotation marks testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type="clsterRepLasso", prototypes=process$prototypes)) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=c("clusterRepLasso", "protolasso"), prototypes=process$prototypes), "length(type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=2, prototypes=process$prototypes), "is.character(type) is not TRUE", fixed=TRUE) testthat::expect_error(checkGetXglmnetInputs(x=process$x, clusters=process$clusters, type=as.character(NA), prototypes=process$prototypes), "!is.na(type) is not TRUE", fixed=TRUE) }) ## Test passed with 5 successes. Tests for getXglmnet(): testthat::test_that("getXglmnet works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10) res <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the prototypes. Features 9 - 11 are # in clusters by themselves and are therefore their own prototypes. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ proto_i_found <- FALSE cluster_i <- good_clusters[[i]] for(j in 1:length(cluster_i)){ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) < 10^(-9)) } testthat::expect_true(proto_i_found) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) res <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the cluster representatives. Features 9 # - 11 are in clusters by themselves and are therefore their own cluster # representatives. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ cluster_i <- good_clusters[[i]] clus_rep_i <- rowMeans(x[, cluster_i]) testthat::expect_true(all(abs(res[, i] - clus_rep_i) < 10^(-9))) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) # X as a data.frame X_df <- datasets::mtcars res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3, nlambda=10) ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1) proto_found <- FALSE for(j in 1:3){ proto_found <- proto_found | all(abs(ret_df[, 1] - X_df_model[, j]) < 10^(-9)) } testthat::expect_true(proto_found) for(j in 4:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9))) } ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1) proto_found <- FALSE clus_rep <- rowMeans(X_df_model[, 1:3]) testthat::expect_true(all(abs(ret_df[, 1] - clus_rep) < 10^(-9))) for(j in 4:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9))) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)), clusters=list(), nlambda=10) ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso", prototypes=res$prototypes) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model)) for(j in 1:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9))) } ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso", prototypes=res$prototypes) testthat::expect_true(is.matrix(ret_df)) testthat::expect_true(is.numeric(ret_df)) testthat::expect_identical(colnames(ret_df), names(res$clusters)) testthat::expect_true(nrow(ret_df) == nrow(X_df)) # Each column of ret_df should be one of the prototypes. testthat::expect_true(ncol(ret_df) == ncol(X_df_model)) for(j in 1:ncol(X_df_model)){ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9))) } # X as a matrix with column names (returned X shouldn't have column names) x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10) res <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the prototypes. Features 9 - 11 are # in clusters by themselves and are therefore their own prototypes. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ proto_i_found <- FALSE cluster_i <- good_clusters[[i]] for(j in 1:length(cluster_i)){ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) < 10^(-9)) } testthat::expect_true(proto_i_found) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) res <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) testthat::expect_true(is.matrix(res)) testthat::expect_true(is.numeric(res)) testthat::expect_identical(colnames(res), names(process$clusters)) testthat::expect_true(nrow(res) == 15) # Each column of res should be one of the cluster representatives. Features 9 # - 11 are in clusters by themselves and are therefore their own cluster # representatives. testthat::expect_true(ncol(res) == 5) for(i in 1:length(good_clusters)){ cluster_i <- good_clusters[[i]] clus_rep_i <- rowMeans(x[, cluster_i]) testthat::expect_true(all(abs(res[, i] - clus_rep_i) < 10^(-9))) } testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9))) testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9))) testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9))) # Bad prototype inputs # Error has quotation marks testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type="clsterRepLasso", prototypes=process$prototypes)) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=c("clusterRepLasso", "protolasso"), prototypes=process$prototypes), "length(type) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=2, prototypes=process$prototypes), "is.character(type) is not TRUE", fixed=TRUE) testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters, type=as.character(NA), prototypes=process$prototypes), "!is.na(type) is not TRUE", fixed=TRUE) # do.call(cbind) preserves integer storage of an integer x (#58) x_int <- matrix(1:12, nrow = 4, ncol = 3) int_clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L) res_int <- getXglmnet(x_int, int_clusters, type = "protolasso", prototypes = c(1L, 2L, 3L)) testthat::expect_true(is.integer(res_int)) }) ## Test passed with 117 successes. Tests for getSelectedSets(): testthat::test_that("getSelectedSets works", { set.seed(82612) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[5]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # Try again with cluster representative lasso X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[5]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)), clusters=1:3, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should throw an error if we assign clusters because df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=1:3, nlambda=100), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should throw an error if we assign clusters because df2 contains factors # with more than two levels testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=1:3, nlambda=100), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) # Pick an arbitrary lasso set lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]] res <- getSelectedSets(lasso_set, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_set", "selected_clusts_list")) # selected_set testthat::expect_true(is.integer(res$selected_set)) testthat::expect_true(all(!is.na(res$selected_set))) testthat::expect_true(all(res$selected_set %in% process$prototypes)) # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) testthat::expect_equal(length(res$selected_set), length(res$selected_clusts_list)) sel_feats <- unlist(res$selected_clusts_list) testthat::expect_true(all(sel_feats %in% 1:11)) n_clusts <- length(res$selected_clusts_list) for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } }) ## Test passed with 80 successes. Tests for getClusterSelsFromGlmnet(): testthat::test_that("getClusterSelsFromGlmnet works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) # Deliberately the raw predict.glmnet idiom rather than clusterLassoCore()'s # normalisation (#190). These fixtures exercise the CONSUMER against the # installed glmnet, bypassing the boundary on purpose, which is what makes # them complementary to the mocked shape pins further below; copying the # normalisation in here would defeat that. # # The two assertions beside each such fixture -- here and in the # "getSelectedSets works" block above -- are the canary for that choice. On a # glmnet that returned a data.frame, the fixtures in THIS block would stop at # the consumer's new guard, but that block's would not: it indexes a single # element out and calls getSelectedSets(), which this PR does not guard, and # a data.frame's [[k]] is column k -- a well-formed integer vector whose # assertions pass silently. The canary makes both blocks fail the same, # legible way instead. # # BOTH assertions are needed, for the same reason the consumer needs two # guards: a data.frame IS a list, so expect_true(is.list(...)) alone passes # on the very container this is watching for. The pair mirrors # getClusterSelsFromGlmnet()'s own stopifnot() pair exactly. lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # Try again with cluster representative lasso X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)), clusters=1:3, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)), clusters=list(), nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="clusterRepLasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=100) X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters, type="protolasso", prototypes=process$prototypes) fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100) lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero")) testthat::expect_true(is.list(lasso_sets)) testthat::expect_false(is.data.frame(lasso_sets)) res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters, process$prototypes, process$var_names) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(process$clusters)){ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # An all-empty lasso path (max_length == 0) must return an empty selection, # not crash with "model_size > 0 is not TRUE" (#157). out_empty <- getClusterSelsFromGlmnet(list(integer(0)), clusters = list(1L), prototypes = 1L, feat_names = NA) testthat::expect_length(out_empty$selected_sets, 0) testthat::expect_length(out_empty$selected_clusts_list, 0) }) ## Test passed with 594 successes. predict.glmnet(type = \"nonzero\") does not return a stable container across glmnet versions here either, and unlike cssLasso() this path must preserve one slot per penalty rather than flatten them. clusterLassoCore() therefore normalises the result to a list before unique() sees it, and getClusterSelsFromGlmnet() refuses anything else (#190). These blocks mock glmnet::predict.glmnet to hand protolasso() and clusterRepLasso() each container shape directly, so they pin the contract on any machine regardless of which glmnet is installed – a test exercising only the installed version pins nothing about the other one. glmnet() itself is not mocked, so fit is a real fit whose path length is whatever the installed glmnet’s early-stopping heuristics produce (nlambda is a request, not a promise: measured on the protolasso design these blocks build, nlambda = 100 yields 66 penalties, and 61 on the clusterRepLasso() design the multi-column block uses). The mocks that need a whole-path fixture therefore size it from ncol(object$beta) rather than hard-coding a slot count, which would be a stopifnot() error rather than a legible test failure. The two blocks that pin a specific geometry – the square one and the neither-orientation one – hard-code theirs instead, and assert or exploit the path length rather than deriving it. Only the single-column data.frame block is a red-green regression test for the container bug proper. The multi-column, list and square blocks are pins that pass on the pre-fix source too. The blocks named requires one entry per penalty, rejects a data.frame and rejects a non-list pin the boundary’s entry-count assertion and the consumer’s two container guards, each of which is otherwise observed by nothing. The boundary’s own is.list() / !is.data.frame() pair is deliberately unpinned: both are post-conditions on a total normalisation, so nothing short of mocking a container nonzeroCoef() cannot emit would reach them. They stand as defence-in-depth against a future glmnet, and deleting either leaves every block below green – the expected result, not a coverage gap. The inner nrow() check in the row-major branch is a different case and is pinned, by the block named rejects a data.frame of neither orientation. It is that branch’s own disambiguation predicate rather than a post-condition, and its unreachability is empirical – no glmnet in play emits a data.frame whose ncol and nrow both differ from the penalty count – rather than structural, so it is worth one assertion. testthat::test_that("clusterLassoCore normalises a single-column data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # glmnet 4.x's shape when every penalty selected exactly ONE feature: apply() # collapses to a vector, so data.frame() gives a single column with one ROW # per penalty and the column<->penalty convention inverts. Read as a list # this is one model of size n_pen; read correctly it is n_pen models of size # 1. The values must cycle through more than one index, or the two readings # coincide and this block cannot go red. # # The cycle needs n_pen >= 3, so assert it rather than documenting it: at # n_pen == 1 the fixture is a 1 x 1 data.frame, both readings agree, and this # block would pass pre-fix -- a green red-green test, which is worse than no # test at all. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ testthat::expect_gte(ncol(object$beta), 3L) data.frame(which=rep_len(c(1L, 2L, 3L), ncol(object$beta))) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=100) # Pre-fix, unique() dedupes the data.frame's ROWS and lengths() then counts # rows per column, so this fixture is read as max_length = 3: the block sees # selected_sets of length 3, holding a fabricated size-3 model c(1L, 7L, 9L) # that glmnet never selected, and drops the genuine size-1 one. Both # assertions below move. testthat::expect_length(res$selected_sets, 1) testthat::expect_identical(res$selected_sets[[1]], 1L) }) testthat::test_that("clusterLassoCore normalises a multi-column data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # glmnet 4.x's other data.frame layout: every penalty selected the same # NUMBER k >= 2 of features -- the sets may differ, {1,2} and {2,3} qualify # -- so apply() returns a k x n_pen matrix and data.frame() lays out one # COLUMN per penalty. This one degenerates to the right answer # pre-fix -- each column is strictly increasing down the rows, so no two rows # can be equal and unique() is a no-op on it -- which makes this a pin rather # than a red-green test. It holds the column-major branch of the # normalisation against a later refactor, and it goes red if the two branches # are transposed or the reshaping is deleted. # # Driven through clusterRepLasso() so the shared clusterLassoCore() body is # covered from both exported entry points. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ n_pen <- ncol(object$beta) as.data.frame(matrix(rep_len(c(1L, 2L, 1L, 3L), 2L*n_pen), nrow=2L, ncol=n_pen)) }, .package="glmnet") res <- clusterRepLasso(x, y, good_clusters, nlambda=100) # Design indices 1 and 2 are red_cluster and green_cluster, whose prototypes # are features 1 and 7; getSelectedSets() maps the fixture's indices back # through prototypes, so these are not the fixture's own integers. testthat::expect_length(res$selected_sets, 2) testthat::expect_null(res$selected_sets[[1]]) testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L)) }) testthat::test_that("clusterLassoCore leaves the list shape alone (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The branch glmnet 5.0 always takes, and the one 4.x takes here today. # Mixed sizes and a NULL slot, so the fixture is not degenerate. # # This is a pin, not a red-green test, and it is deliberately kept despite # being green pre-fix: measured green under deleting the reshaping and under # replacing it with a bare as.list(), because both leave a list untouched. # What it does catch is applying the reshaping UNCONDITIONALLY -- dropping # the is.data.frame() test on the grounds that "the reshape is harmless on a # list" is the likeliest future edit to that block -- under which it errors # with "'list' object cannot be coerced to type 'integer'". Apart from the # entry-count block below, which trips a different assertion incidentally, # this block catches that. It is not the only one -- an unconditional # reshape reaches as.integer() on a list from every caller, so the # end-to-end protolasso/clusterRepLasso blocks error too -- but it is the # only one of the mocked shape pins that does. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ testthat::expect_gte(ncol(object$beta), 3L) rep_len(list(NULL, 1L, c(1L, 2L)), ncol(object$beta)) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=100) testthat::expect_length(res$selected_sets, 2) testthat::expect_identical(res$selected_sets[[1]], 1L) testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L)) }) testthat::test_that("getClusterSelsFromGlmnet rejects a data.frame (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) # The message pin separates the NEW guard from the downstream # all(lasso_set <= length(clusters)) check in getSelectedSets(), which fires # only when the fixture's indices exceed length(clusters). Measured on # 2f66a14 with this five-cluster fixture: the call returns cleanly # (selected_sets of length 2), so a bare expect_error() is red-green here as # well -- but it would go green again on any later edit that made this call # error for some unrelated reason, which is why the pin stays. # # fixed=TRUE is mandatory: the message contains "!", "(" and ".", so it does # not match itself as a regex. testthat::expect_error( getClusterSelsFromGlmnet(data.frame(which=c(1L, 2L)), process$clusters, process$prototypes, process$var_names), "!is.data.frame(lasso_sets) is not TRUE", fixed=TRUE) }) testthat::test_that("clusterLassoCore requires one entry per penalty (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The entry-count assertion is a new bound on the default code path: before # #190 clusterLassoCore() accepted whatever predict.glmnet handed it, # afterwards it refuses anything whose entry count differs from # ncol(fit$beta). Nothing else observes it, so without this block a later # weakening of it would go unnoticed. On glmnet 4.1.9 the bound excludes # nothing (400/400 agreement over random fits); CI's R-CMD-check matrix, # which installs glmnet 5.0, is its cross-version test. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ rep_len(list(1L), ncol(object$beta) + 1L) }, .package="glmnet") testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100), "identical(length(nonzero), n_pen) is not TRUE", fixed=TRUE) }) testthat::test_that("getClusterSelsFromGlmnet rejects a non-list (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=100) # The data.frame block above can never reach the is.list() guard, because a # data.frame IS a list and its fixture always falls through to the second # guard; this block is the only thing that exercises the first. Measured on # 2f66a14: this call returns cleanly (selected_sets of length 1), so the red # side is a clean "no error was thrown". testthat::expect_error( getClusterSelsFromGlmnet(1:3, process$clusters, process$prototypes, process$var_names), "is.list(lasso_sets) is not TRUE", fixed=TRUE) }) testthat::test_that("clusterLassoCore reads a square data.frame column-major (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # The one shape on which BOTH branch predicates are true: k == n_pen, so # ncol(nonzero_mat) == n_pen and nrow(nonzero_mat) == n_pen alike. The # normalisation resolves it by testing ncol first, which is correct -- # apply() simplifies to a matrix only when it has one column per penalty -- # but nothing else in this file pins that ORDER, because no other fixture is # square (the single-column one is n_pen x 1, the multi-column one 2 x n_pen). # # Swapping the predicate and the two readings together is wrong on exactly # this shape and correct everywhere else, so without this block that refactor # passes the whole suite while reintroducing #190's failure mode: confidently # wrong model sizes. Read row-major, slot 1 is ROW 1 -- c(1L, 1L, 1L) -- # which getSelectedSets() rejects for having duplicates. # # nlambda is honoured exactly at small values (measured: 2 -> 2, 3 -> 3), so # a square fixture is directly constructible; assert it rather than trusting # it, since a shortened path would make this block vacuous. testthat::local_mocked_bindings( predict.glmnet = function(object, ...){ n_pen <- ncol(object$beta) testthat::expect_identical(n_pen, 3L) as.data.frame(matrix(c(1L, 2L, 3L, 1L, 2L, 4L, 1L, 3L, 4L), nrow=3L, ncol=3L)) }, .package="glmnet") res <- protolasso(x, y, good_clusters, nlambda=3) # Prototypes are c(1, 7, 9, 10, 11), so the fixture's first column c(1, 2, 3) # maps to features 1, 7 and 9. testthat::expect_length(res$selected_sets, 3) testthat::expect_null(res$selected_sets[[1]]) testthat::expect_null(res$selected_sets[[2]]) testthat::expect_identical(res$selected_sets[[3]], c(1L, 7L, 9L)) }) ## Test passed with 3 successes. ## Test passed with 3 successes. ## Test passed with 4 successes. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 1 success. ## Test passed with 5 successes. The last of the boundary’s assertions, the row-major branch’s own nrow() check. Unlike the is.list() / !is.data.frame() pair it guards a reachable-in-principle shape – a data.frame whose ncol and nrow both differ from the penalty count – so it costs one assertion rather than being unpinnable. testthat::test_that("clusterLassoCore rejects a data.frame of neither orientation (#190)", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Neither ncol nor nrow matches n_pen (66 on this design at nlambda = 100), # so the reshaping cannot tell which orientation it is looking at and stops # instead of guessing. No glmnet in play emits this, which is why the guard # is otherwise unobserved. testthat::local_mocked_bindings( predict.glmnet = function(...) data.frame(a=1:2, b=3:4), .package="glmnet") testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100), "nrow(nonzero_mat) == n_pen is not TRUE", fixed=TRUE) }) ## Test passed with 1 success. Finally, tests for protolasso(): testthat::test_that("protolasso works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(x, y, good_clusters, nlambda=60) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(is.null(names(res$selected_sets[[i]]))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 60) # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] y_df <- rnorm(nrow(X_df)) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(X_df, y_df, 1:3, nlambda=80) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 80) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Should get an error if we try to call protolasso on df2 with clusters # because df2 contains factors with more than two levels testthat::expect_error(protolasso(df2, y_df, 4:6, nlambda=70), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- protolasso(df2, y_df, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(X_df_model, y_df, 4:6, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 70) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x2, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- protolasso(x2, y, good_clusters, nlambda=50) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% LETTERS[1:11])) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 50) # Bad inputs testthat::expect_error(protolasso(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156); the fitted result for a # duplicated cluster is identical to passing the cluster once (seed both). set.seed(921) dup_pl <- protolasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10) set.seed(921) dedup_pl <- protolasso(X=x, y=y, clusters=list(2:3), nlambda=10) testthat::expect_identical(dup_pl, dedup_pl) testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) # (#127) A single all-encompassing cluster (or a genuine p < 2 input) leaves # glmnet with a 1-column design; clusterLassoCore now errors up front with a # cssr message naming both causes, instead of glmnet's "2 or more columns". testthat::expect_error( protolasso(X=x, y=y, clusters=list(all=1:11)), "need at least 2 cluster representatives to fit the lasso", fixed=TRUE) }) ## Test passed with 575 successes. Tests for clusterRepLasso(): testthat::test_that("clusterRepLasso works", { set.seed(61282) x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11) y <- stats::rnorm(15) good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(x, y, good_clusters, nlambda=60) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(is.null(names(res$selected_sets[[i]]))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 60) # X as a data.frame X_df <- datasets::mtcars X_df_model <- stats::model.matrix(~ ., X_df) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] y_df <- rnorm(nrow(X_df)) # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(X_df, y_df, 1:3, nlambda=80) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 80) # 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 df2) # cyl, gear, and carb are factors with more than 2 levels df2 <- X_df df2$cyl <- as.factor(df2$cyl) df2$vs <- as.factor(df2$vs) df2$am <- as.factor(df2$am) df2$gear <- as.factor(df2$gear) df2$carb <- as.factor(df2$carb) # Should get an error if we try to call clusterRepLasso on df2 with clusters # because df2 contains factors with more than two levels testthat::expect_error(clusterRepLasso(df2, y_df, 4:6, nlambda=70), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE) # Should be fine if no clusters are provided res <- clusterRepLasso(df2, y_df, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) X_df_model <- stats::model.matrix(~ ., df2) X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model), get_prototypes=TRUE, x=X_df_model, y=y_df) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(X_df_model, y_df, 4:6, nlambda=70) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% colnames(X_df_model))) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model))) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1) testthat::expect_true(ncol(res$beta) <= 70) # X as a matrix with column names x2 <- x colnames(x2) <- LETTERS[1:11] # Get properly formatted clusters and prototypes for testing format_clust_res <- formatClusters(clusters=good_clusters, p=11, clust_names=names(good_clusters), get_prototypes=TRUE, x=x2, y=y) prototypes <- format_clust_res$prototypes clus_formatted <- format_clust_res$clusters res <- clusterRepLasso(x2, y, good_clusters, nlambda=50) testthat::expect_true(is.list(res)) testthat::expect_identical(names(res), c("selected_sets", "selected_clusts_list", "beta")) # selected_sets testthat::expect_true(is.list(res$selected_sets)) # Selected models should have one of each size without repetition lengths <- lengths(res$selected_sets) lengths <- lengths[lengths != 0] testthat::expect_identical(lengths, unique(lengths)) for(i in 1:length(res$selected_sets)){ if(!is.null(res$selected_sets[[i]])){ testthat::expect_true(is.integer(res$selected_sets[[i]])) testthat::expect_true(all(!is.na(res$selected_sets[[i]]))) testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes)) testthat::expect_equal(length(res$selected_sets[[i]]), i) testthat::expect_true(all(names(res$selected_sets[[i]]) %in% LETTERS[1:11])) } else{ testthat::expect_true(is.null(res$selected_sets[[i]])) } } # selected_clusts_list testthat::expect_true(is.list(res$selected_clusts_list)) # Selected models should have one of each size without repetition clust_lengths <- lengths(res$selected_clusts_list) clust_lengths <- clust_lengths[clust_lengths != 0] testthat::expect_identical(clust_lengths, unique(clust_lengths)) for(k in 1:length(res$selected_clusts_list)){ if(!is.null(res$selected_clusts_list[[k]])){ testthat::expect_true(is.list(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_sets[[k]]), length(res$selected_clusts_list[[k]])) testthat::expect_equal(length(res$selected_clusts_list[[k]]), k) sel_feats <- unlist(res$selected_clusts_list[[k]]) testthat::expect_true(all(sel_feats %in% 1:11)) testthat::expect_equal(length(sel_feats), length(unique(sel_feats))) n_clusts <- k for(i in 1:n_clusts){ clust_i_found <- FALSE clust_i <- res$selected_clusts_list[[k]][[i]] for(j in 1:length(clus_formatted)){ clust_i_found <- clust_i_found | identical(clust_i, clus_formatted[[j]]) } testthat::expect_true(clust_i_found) } } else{ testthat::expect_true(is.null(res$selected_clusts_list[[k]])) } } # beta testthat::expect_true(grepl("dgCMatrix", class(res$beta))) testthat::expect_true(nrow(res$beta) == 11 - 8 + 2) testthat::expect_true(ncol(res$beta) <= 50) # Bad inputs testthat::expect_error(clusterRepLasso(X="x", y=y[1:10], clusters=good_clusters, nlambda=10), "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y[1:10], clusters=good_clusters, nlambda=10), "n == length(y) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, 4:6), nlambda=10), "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE) # Duplicate clusters are now silently removed (#156); identical to passing the # cluster once (seed both). set.seed(921) dup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10) set.seed(921) dedup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3), nlambda=10) testthat::expect_identical(dup_crl, dedup_crl) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, as.integer(NA)), nlambda=10), "!is.na(clusters) are not all TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)), nlambda=10), "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=1), "nlambda >= 2 is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=x), "length(nlambda) == 1 is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda="nlambda"), "is.numeric(nlambda) | is.integer(nlambda) is not TRUE", fixed=TRUE) testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters, nlambda=10.5), "nlambda == round(nlambda) is not TRUE", fixed=TRUE) # (#127) Same degenerate-design guard as protolasso: a single all-encompassing # cluster yields a 1-column design, now rejected with a clear cssr message # rather than glmnet's "2 or more columns". testthat::expect_error( clusterRepLasso(X=x, y=y, clusters=list(all=1:11)), "need at least 2 cluster representatives to fit the lasso", fixed=TRUE) }) ## Test passed with 527 successes. Regression test for the empty-lasso-path edge case (#157): testthat::test_that("protolasso/clusterRepLasso return an empty selection when the lasso path selects nothing (#157)", { # X'y must be EXACTLY zero to empty the whole glmnet path (see plan note: # floating-point orthogonality drives lambda_max->0 and selects everything). # Paired +1/-1 integer rows give crossprod(X, y) == 0 exactly. y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1)) X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0), c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1)) storage.mode(X) <- "double" testthat::expect_identical(max(abs(crossprod(X, y))), 0) # exactly orthogonal # Was: crash "model_size > 0 is not TRUE". Now: empty selection, no error. res_p <- protolasso(X, y) testthat::expect_length(res_p$selected_sets, 0) testthat::expect_length(res_p$selected_clusts_list, 0) res_c <- clusterRepLasso(X, y) testthat::expect_length(res_c$selected_sets, 0) testthat::expect_length(res_c$selected_clusts_list, 0) # A normal signal case still selects features (guards against over-fixing). set.seed(2) Xs <- matrix(stats::rnorm(24 * 4), 24, 4) ys <- Xs[, 1] * 2 + stats::rnorm(24, sd = 0.1) testthat::expect_gt(length(protolasso(Xs, ys)$selected_sets), 0) }) ## Test passed with 6 successes. Regression tests for the named output contract of protolasso()/clusterRepLasso(): selected_clusts_list[[k]] is a named list of the selected clusters (#158a). testthat::test_that("protolasso and clusterRepLasso name selected_clusts_list with the selected clusters' names (#158a)", { set.seed(158) n <- 40L p <- 6L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n)) clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L)) # formatClusters reorders to clustA, clustB, then one singleton per unclustered # feature in ascending order (c3 = feature 1, c4 = feature 3). expected_names <- c("clustA", "clustB", "c3", "c4") for (fun in list(protolasso, clusterRepLasso)) { res <- fun(X, y, clusters) testthat::expect_true(any(lengths(res$selected_clusts_list) > 0)) for (k in seq_along(res$selected_clusts_list)) { sk <- res$selected_clusts_list[[k]] if (length(sk) > 0) { testthat::expect_false(is.null(names(sk))) testthat::expect_equal(length(names(sk)), k) testthat::expect_true(all(names(sk) %in% expected_names)) # Name-based indexing returns the same cluster as position-based. testthat::expect_identical(sk[[names(sk)[1]]], sk[[1]]) } } } }) ## Test passed with 26 successes. The rows of beta carry the reordered cluster names, so they cross-reference selected_clusts_list (#158b). testthat::test_that("protolasso and clusterRepLasso beta carries cluster names as rownames (#158b)", { set.seed(158) n <- 40L p <- 6L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n)) clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L)) expected_names <- c("clustA", "clustB", "c3", "c4") for (fun in list(protolasso, clusterRepLasso)) { res <- fun(X, y, clusters) # GUARANTEED equality: one beta row per reordered cluster, in order. testthat::expect_identical(rownames(res$beta), expected_names) # SUBSET cross-check: each selected cluster's name is among beta's rownames # (a never-selected cluster is still a beta row, so this is not equality). for (k in seq_along(res$selected_clusts_list)) { sk <- res$selected_clusts_list[[k]] if (length(sk) > 0) { testthat::expect_true(all(names(sk) %in% rownames(res$beta))) } } } }) ## Test passed with 8 successes. processClusterLassoInputs() rejects an X whose columns are partly named and partly NA-named, with the corrected remedy message (#158d). testthat::test_that("processClusterLassoInputs rejects X with mixed named and NA-named columns (#158d)", { set.seed(158) n <- 20L p <- 4L X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p) colnames(X) <- c("g1", NA, "g3", NA) y <- stats::rnorm(n) testthat::expect_error( processClusterLassoInputs(X = X, y = y, clusters = list(), nlambda = 10), "please either name all features in X or remove the names altogether", fixed = TRUE) }) ## Test passed with 1 success. "],["documenting-the-package-and-adding-readme-and-pkgdown-website.html", "13 Documenting the package and adding README and pkgdown website", " 13 Documenting the package and adding README and pkgdown website At build time we generate the package’s reference documentation, README, and pkgdown website: litr::document() writes the man/ pages and NAMESPACE; the README is rendered from source-files/README.Rmd (its two figures copied into man/figures/); the CITATION file is installed so citation(\"cssr\") and the pkgdown “Citation” page cite the paper (arXiv:2201.00494); NEWS.md is copied to the package root from source-files/NEWS.md, where it is edited, so that news(package = \"cssr\") and the pkgdown “Changelog” page both have it (it must be copied before litr::add_pkgdown() runs below, since that is what builds the changelog page); and the WORDLIST file is installed alongside CITATION so that devtools::spell_check() accepts this package’s domain vocabulary and flags only genuine misspellings. Its entries fall into a few groups: author surnames and the journals that published them; package, function, and argument names; data-frame column names; fragments of underscore-separated identifiers, which appear because the spell checker splits tokens at underscores (so X_train_selec contributes selec, and clus_sel_mat contributes clus and sel — these are documented argument and slot names, not truncations); a few mathematical and typographic tokens from the README’s LaTeX; the R color literals grey and steelblue, which are spellings fixed by R’s own palette rather than by us and so are quoted verbatim from default argument values; and a handful of ordinary English words the en_US dictionary happens to lack. Everything else is treated as a typo and fixed at the source; the Exploring results, Prediction, and Advanced usage vignettes are added from source-files/ via litr::add_vignettes(); and litr::add_pkgdown() builds the site (including the vignettes under Articles). "],["404.html", "Page not found", " Page not found The page you requested cannot be found (perhaps it was moved or renamed). You may want to try searching to find the page's new location, or use the table of contents to find the page you are looking for. "]]
diff --git a/docs/create/sel-and-pred.html b/docs/create/sel-and-pred.html
index 1270c535..4700eb44 100644
--- a/docs/create/sel-and-pred.html
+++ b/docs/create/sel-and-pred.html
@@ -12,7 +12,7 @@
-
+
@@ -249,92 +249,93 @@
#' nonzero weight within the selected clusters will be returned. Must be one of
#' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is
#' put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", only the features within a selected cluster that were
-#' themselves selected on at least one subsample will have nonzero weight.
-#' (Exception: if no member of a selected cluster was selected on any subsample,
-#' the weights fall back to a simple average, so all of that cluster's members
-#' are returned.) For "simple_avg", each cluster
-#' member gets equal weight regardless of the individual feature selection
-#' proportions (that is, all cluster members within each selected cluster will
-#' be returned.). See Faletto and Bien (2022) for details. Default is "sparse".
-#' @param cutoff Numeric; getCssSelections will select and return only of those
-#' clusters with selection proportions equal to at least cutoff. Must be between
-#' 0 and 1. Default is 0 (in which case either all clusters are selected, or
-#' max_num_clusts are selected, if max_num_clusts is specified).
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow
-#' a pure cutoff-based (threshold) selection that returns an empty set when no
-#' cluster's selection proportion meets the cutoff.
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored). Because clusters can have tied selection
-#' proportions, ties at the threshold can cause more than max_num_clusts (or
-#' fewer than min_num_clusts) clusters to be returned; when the two constraints
-#' conflict, max_num_clusts takes precedence.
-#' @return A named list with three items. \item{selected_clusts}{A named list of
-#' integer vectors; each vector contains the indices of the features in one of
-#' the selected clusters.} \item{selected_feats}{A named integer vector; the
-#' indices of the features with nonzero weights from all of the selected
-#' clusters.} \item{weights}{A named list of the same length as selected_clusts.
-#' Each list element `weights[[j]]` is a numeric vector of the weights to use for
-#' the jth selected cluster, and it has the same name as the cluster it
-#' corresponds to.}
-#' @author Gregory Faletto, Jacob Bien
-#' @references
-<<faletto2022>>
-#' @examples
-#' set.seed(1)
-#' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' clusters <- list(cluster1 = 1:4)
-#' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters,
-#' B = 10)
-#' getCssSelections(res)
-#' @export
-getCssSelections <- function(css_results, weighting="sparse", cutoff=0,
- min_num_clusts=1, max_num_clusts=NA){
- # Check inputs
- stopifnot(inherits(css_results, "cssr"))
- checkCutoff(cutoff)
- checkWeighting(weighting)
-
- p <- ncol(css_results$feat_sel_mat)
-
- checkMinNumClusts(min_num_clusts, p, length(css_results$clusters))
-
- max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p,
- length(css_results$clusters))
-
- sel_results <- getSelectedClusters(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts)
-
- # sel_results$selected_clusts is guaranteed to have length at least 1 by
- # getSelectedClusters
- sel_clust_names <- names(sel_results$selected_clusts)
-
- stopifnot(length(sel_clust_names) >= 0)
- stopifnot(all(sel_clust_names %in% names(css_results$clusters)))
-
- sel_clusts <- list()
- for(i in seq_along(sel_clust_names)){
- sel_clusts[[i]] <- css_results$clusters[[sel_clust_names[i]]]
- names(sel_clusts)[i] <- sel_clust_names[i]
- }
-
- stopifnot(is.list(sel_clusts))
- stopifnot(length(sel_clusts) == length(sel_clust_names))
-
- # sel_results$selected_feats is guaranteed to have length at least as long
- # as sel_results$selected_clusts by getSelectedClusters
- return(list(selected_clusts=sel_clusts,
- selected_feats=sel_results$selected_feats, weights=sel_results$weights))
-}
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", only the features within a selected cluster that were
+#' themselves selected on at least one subsample will have nonzero weight.
+#' (Exception: if no member of a selected cluster was selected on any subsample,
+#' the weights fall back to a simple average, so all of that cluster's members
+#' are returned.) For "simple_avg", each cluster
+#' member gets equal weight regardless of the individual feature selection
+#' proportions (that is, all cluster members within each selected cluster will
+#' be returned.). See Faletto and Bien (2022) for details. Default is "sparse".
+#' @param cutoff Numeric; getCssSelections will select and return only of those
+#' clusters with selection proportions equal to at least cutoff. Must be between
+#' 0 and 1. Default is 0 (in which case either all clusters are selected, or
+#' max_num_clusts are selected, if max_num_clusts is specified).
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.) Default is 1. May be set to 0 to allow
+#' a pure cutoff-based (threshold) selection that returns an empty set when no
+#' cluster's selection proportion meets the cutoff.
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored). Because clusters can have tied selection
+#' proportions, ties at the threshold can cause more than max_num_clusts (or
+#' fewer than min_num_clusts) clusters to be returned; when the two constraints
+#' conflict, max_num_clusts takes precedence.
+#' @return A named list with three items. \item{selected_clusts}{A named list of
+#' integer vectors; each vector contains the indices of the features in one of
+#' the selected clusters.} \item{selected_feats}{A named integer vector; the
+#' indices of the features with nonzero weights from all of the selected
+#' clusters.} \item{weights}{A named list of the same length as selected_clusts.
+#' Each list element `weights[[j]]` is a numeric vector of the weights to use for
+#' the jth selected cluster, and it has the same name as the cluster it
+#' corresponds to.}
+#' @author Gregory Faletto, Jacob Bien
+#' @references
+<<faletto2022>>
+#' @examples
+#' set.seed(1)
+#' data <- genClusteredData(n = 50, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' clusters <- list(cluster1 = 1:4)
+#' res <- css(X = data$X, y = data$y, lambda = 0.01, clusters = clusters,
+#' B = 10)
+#' getCssSelections(res)
+#' @export
+getCssSelections <- function(css_results, weighting="sparse", cutoff=0,
+ min_num_clusts=1, max_num_clusts=NA){
+ # Check inputs
+ stopifnot(inherits(css_results, "cssr"))
+ checkCutoff(cutoff)
+ checkWeighting(weighting)
+
+ p <- ncol(css_results$feat_sel_mat)
+
+ checkMinNumClusts(min_num_clusts, p, length(css_results$clusters))
+
+ max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p,
+ length(css_results$clusters))
+
+ sel_results <- getSelectedClusters(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts)
+
+ # sel_results$selected_clusts is guaranteed to have length at least 1 by
+ # getSelectedClusters
+ sel_clust_names <- names(sel_results$selected_clusts)
+
+ stopifnot(length(sel_clust_names) >= 0)
+ stopifnot(all(sel_clust_names %in% names(css_results$clusters)))
+
+ sel_clusts <- list()
+ for(i in seq_along(sel_clust_names)){
+ sel_clusts[[i]] <- css_results$clusters[[sel_clust_names[i]]]
+ names(sel_clusts)[i] <- sel_clust_names[i]
+ }
+
+ stopifnot(is.list(sel_clusts))
+ stopifnot(length(sel_clusts) == length(sel_clust_names))
+
+ # sel_results$selected_feats is guaranteed to have length at least as long
+ # as sel_results$selected_clusts by getSelectedClusters
+ return(list(selected_clusts=sel_clusts,
+ selected_feats=sel_results$selected_feats, weights=sel_results$weights))
+}
checkCutoff():
#' Helper function to confirm that the argument cutoff to several functions is
#' as expected
@@ -456,127 +457,131 @@
#' nonzero weight within the selected clusters will be returned. Must be one of
#' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is
#' put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", only the features within a selected cluster that were
-#' themselves selected on at least one subsample will have nonzero weight. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, all cluster members within
-#' each selected cluster will be returned.). See Faletto and Bien (2022) for
-#' details.
-#' @param cutoff Numeric; getCssSelections will select and return only of those
-#' clusters with selection proportions equal to at least cutoff. Must be between
-#' 0 and 1.
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.)
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored.
-#' @return A named list with the following elements: \item{selected_clusts}{A
-#' named numeric vector containing the selection proportions for the selected
-#' clusters. The name of each entry is the name of the corresponding cluster.}
-#' \item{selected_feats}{A named integer vector; the indices of the features
-#' with nonzero weights from all of the selected clusters.} \item{weights}{A
-#' named list of the same length as the number of selected clusters. Each list
-#' element `weights[[j]]` is a numeric vector of the weights to use for the jth
-#' selected cluster, and it has the same name as the cluster it corresponds
-#' to.}
-#' @author Gregory Faletto, Jacob Bien
-#' @keywords internal
-#' @noRd
-getSelectedClusters <- function(css_results, weighting, cutoff, min_num_clusts,
- max_num_clusts){
- # Check input
- stopifnot(inherits(css_results, "cssr"))
-
- # Eliminate clusters with selection proportions below cutoff
- clus_sel_props <- colMeans(css_results$clus_sel_mat)
- B <- nrow(css_results$feat_sel_mat)
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", only the features within a selected cluster that were
+#' themselves selected on at least one subsample will have nonzero weight.
+#' (Exception: if no member of a selected cluster was selected on any subsample,
+#' the weights fall back to a simple average, so all of that cluster's members
+#' are returned.) For
+#' "simple_avg", each cluster member gets equal weight regardless of the
+#' individual feature selection proportions (that is, all cluster members within
+#' each selected cluster will be returned.). See Faletto and Bien (2022) for
+#' details.
+#' @param cutoff Numeric; getCssSelections will select and return only of those
+#' clusters with selection proportions equal to at least cutoff. Must be between
+#' 0 and 1.
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.)
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) If NA, max_num_clusts is ignored.
+#' @return A named list with the following elements: \item{selected_clusts}{A
+#' named numeric vector containing the selection proportions for the selected
+#' clusters. The name of each entry is the name of the corresponding cluster.}
+#' \item{selected_feats}{A named integer vector; the indices of the features
+#' with nonzero weights from all of the selected clusters.} \item{weights}{A
+#' named list of the same length as the number of selected clusters. Each list
+#' element `weights[[j]]` is a numeric vector of the weights to use for the jth
+#' selected cluster, and it has the same name as the cluster it corresponds
+#' to.}
+#' @author Gregory Faletto, Jacob Bien
+#' @keywords internal
+#' @noRd
+getSelectedClusters <- function(css_results, weighting, cutoff, min_num_clusts,
+ max_num_clusts){
+ # Check input
+ stopifnot(inherits(css_results, "cssr"))
- # Selection proportions are exact multiples of 1/B; work in integer count
- # space so the documented ">= cutoff" holds exactly (no float snapping) and
- # the loop thresholds step by whole counts (retires the #42 class). (#159a)
- counts <- round(clus_sel_props * B)
- thresh <- ceiling(cutoff * B - 1e-9)
-
- # Get selected clusters
- selected_clusts <- clus_sel_props[counts >= thresh]
-
- # Check that selected_clusts has length at least min_num_clusts
- while(length(selected_clusts) < min_num_clusts){
- # Guard against an unbounded decrement if min_num_clusts exceeds the
- # number of clusters: once every cluster is selected we can't select
- # more, so stop (mirrors the max-loop's break) (#69). Unreachable via the
- # public API (checkMinNumClusts enforces min_num_clusts <= n_clusters),
- # but a defensive break for any internal caller.
- if(length(selected_clusts) == length(clus_sel_props)){
- break
- }
- thresh <- thresh - 1L
- selected_clusts <- clus_sel_props[counts >= thresh]
- }
-
- # Check that selected_clusts has length at most max_num_clusts
- if(!is.na(max_num_clusts)){
- while(length(selected_clusts) > max_num_clusts){
- thresh <- thresh + 1L
- # Once the threshold exceeds B no count can meet it, so stop before
- # emptying the selection (retires the #42 float-accumulation break).
- if(thresh > B){
- break
- }
- # Make sure we don't reduce to a selected set of size 0
- if(any(counts >= thresh)){
- selected_clusts <- clus_sel_props[counts >= thresh]
- } else{
- break
- }
- }
- }
-
- stopifnot(length(selected_clusts) >= 0)
-
- clust_names <- names(selected_clusts)
+ # Eliminate clusters with selection proportions below cutoff
+ clus_sel_props <- colMeans(css_results$clus_sel_mat)
+ B <- nrow(css_results$feat_sel_mat)
+
+ # Selection proportions are exact multiples of 1/B; work in integer count
+ # space so the documented ">= cutoff" holds exactly (no float snapping) and
+ # the loop thresholds step by whole counts (retires the #42 class). (#159a)
+ counts <- round(clus_sel_props * B)
+ thresh <- ceiling(cutoff * B - 1e-9)
+
+ # Get selected clusters
+ selected_clusts <- clus_sel_props[counts >= thresh]
+
+ # Check that selected_clusts has length at least min_num_clusts
+ while(length(selected_clusts) < min_num_clusts){
+ # Guard against an unbounded decrement if min_num_clusts exceeds the
+ # number of clusters: once every cluster is selected we can't select
+ # more, so stop (mirrors the max-loop's break) (#69). Unreachable via the
+ # public API (checkMinNumClusts enforces min_num_clusts <= n_clusters),
+ # but a defensive break for any internal caller.
+ if(length(selected_clusts) == length(clus_sel_props)){
+ break
+ }
+ thresh <- thresh - 1L
+ selected_clusts <- clus_sel_props[counts >= thresh]
+ }
+
+ # Check that selected_clusts has length at most max_num_clusts
+ if(!is.na(max_num_clusts)){
+ while(length(selected_clusts) > max_num_clusts){
+ thresh <- thresh + 1L
+ # Once the threshold exceeds B no count can meet it, so stop before
+ # emptying the selection (retires the #42 float-accumulation break).
+ if(thresh > B){
+ break
+ }
+ # Make sure we don't reduce to a selected set of size 0
+ if(any(counts >= thresh)){
+ selected_clusts <- clus_sel_props[counts >= thresh]
+ } else{
+ break
+ }
+ }
+ }
- n_sel_clusts <- length(selected_clusts)
+ stopifnot(length(selected_clusts) >= 0)
- # Check that n_sel_clusts is as expected, and throw warnings or an error if
- # not
- checkSelectedClusters(n_sel_clusts, min_num_clusts, max_num_clusts,
- max(clus_sel_props))
-
- ### Get selected features from selected clusters
- clusters <- css_results$clusters
- stopifnot(all(clust_names %in% names(clusters)))
-
- # Get a list of weights for all of the selected clusters
- weights <- getAllClustWeights(css_results, selected_clusts, weighting)
-
- # Get selected features from each cluster (those features with nonzero
- # weights)
- selected_feats <- integer()
- for(i in seq_len(n_sel_clusts)){
- clus_i_name <- clust_names[i]
- clust_i <- clusters[[clus_i_name]]
- weights_i <- weights[[i]]
- selected_feats <- c(selected_feats, clust_i[weights_i != 0])
- }
-
- feat_names <- colnames(css_results$feat_sel_mat)
-
- names(selected_feats) <- feat_names[selected_feats]
+ clust_names <- names(selected_clusts)
+
+ n_sel_clusts <- length(selected_clusts)
+
+ # Check that n_sel_clusts is as expected, and throw warnings or an error if
+ # not
+ checkSelectedClusters(n_sel_clusts, min_num_clusts, max_num_clusts,
+ max(clus_sel_props))
+
+ ### Get selected features from selected clusters
+ clusters <- css_results$clusters
+ stopifnot(all(clust_names %in% names(clusters)))
+
+ # Get a list of weights for all of the selected clusters
+ weights <- getAllClustWeights(css_results, selected_clusts, weighting)
+
+ # Get selected features from each cluster (those features with nonzero
+ # weights)
+ selected_feats <- integer()
+ for(i in seq_len(n_sel_clusts)){
+ clus_i_name <- clust_names[i]
+ clust_i <- clusters[[clus_i_name]]
+ weights_i <- weights[[i]]
+ selected_feats <- c(selected_feats, clust_i[weights_i != 0])
+ }
- # Check output (already checked weights wihin getAllClustWeights)
+ feat_names <- colnames(css_results$feat_sel_mat)
- checkGetSelectedClustersOutput(selected_clusts, selected_feats,
- weights, n_clusters=length(clusters), p=ncol(css_results$feat_sel_mat))
-
- return(list(selected_clusts=selected_clusts,
- selected_feats=selected_feats, weights=weights))
-}
#' Helper function to check operations within getSelectedClusters function
#'
@@ -638,68 +643,72 @@
#' nonzero weight within the selected clusters will be returned. Must be one of
#' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is
#' put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", only the features within a selected cluster that were
-#' themselves selected on at least one subsample will have nonzero weight. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, all cluster members within
-#' each selected cluster will be returned.). See Faletto and Bien (2022) for
-#' details.
-#' @return A named list of the same length as sel_clusters of numeric vectors.
-#' `weights[[j]]` is the weights to use for the jth selected cluster, and it has
-#' the same name as the cluster it corresponds to.
-#' @author Gregory Faletto, Jacob Bien
-#' @keywords internal
-#' @noRd
-getAllClustWeights <- function(css_results, sel_clusters, weighting){
-
- # Check inputs
- stopifnot(inherits(css_results, "cssr"))
-
- stopifnot(is.numeric(sel_clusters))
- p_ret <- length(sel_clusters)
- stopifnot(length(unique(names(sel_clusters))) == p_ret)
- stopifnot(p_ret >= 0)
-
- checkWeighting(weighting)
-
- # Get selection proportions and clusters
- feat_sel_props <- colMeans(css_results$feat_sel_mat)
-
- p <- length(feat_sel_props)
- stopifnot(p >= p_ret)
-
- clusters <- css_results$clusters
- stopifnot(all(names(sel_clusters) %in% names(clusters)))
-
- # Identify weights
- weights <- list()
-
- for(j in seq_len(p_ret)){
- # Find the members of the cluster feature j is a member of
- cluster_j <- clusters[[names(sel_clusters)[j]]]
- # Get the weights for this cluster and add them to the list
- weights[[j]] <- getClustWeights(cluster_j, weighting, feat_sel_props)
- }
-
- # Add names to weights
- names(weights) <- names(sel_clusters)
-
- # Check output
-
- stopifnot(length(weights) == p_ret)
- stopifnot(is.list(weights))
-
- for(i in seq_len(p_ret)){
- stopifnot(length(clusters[[names(sel_clusters)[i]]]) ==
- length(weights[[i]]))
- stopifnot(all(weights[[i]] >= 0))
- stopifnot(all(weights[[i]] <= 1))
- stopifnot(abs(sum(weights[[i]]) - 1) < 10^(-6))
- }
- return(weights)
-}
#' Calculate weights for members of a cluster using selection proportions
#'
@@ -713,77 +722,81 @@
#' nonzero weight within the selected clusters will be returned. Must be one of
#' "sparse", "weighted_avg", or "simple_avg". For "sparse", all the weight is
#' put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", only the features within a selected cluster that were
-#' themselves selected on at least one subsample will have nonzero weight. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, all cluster members within
-#' each selected cluster will be returned.). See Faletto and Bien (2022) for
-#' details.
-#' @param feat_sel_props A numeric vector of selection proportions corresponding
-#' to each of the p features.
-#' @return A numeric vector of the same length as cluster_i containing the
-#' weights corresponding to each of the features in cluster_i. The weights
-#' will all be nonnegative and sum to 1.
-#' @author Gregory Faletto, Jacob Bien
-#' @keywords internal
-#' @noRd
-getClustWeights <- function(cluster_i, weighting, feat_sel_props){
-
- stopifnot(is.integer(cluster_i) | is.numeric(cluster_i))
- stopifnot(all(cluster_i == round(cluster_i)))
- n_weights <- length(cluster_i)
- stopifnot(length(unique(cluster_i)) == n_weights)
-
- p <- length(feat_sel_props)
- stopifnot(all(cluster_i %in% 1:p))
-
- # Get the selection proportions of each cluster member
- sel_props <- feat_sel_props[cluster_i]
-
- stopifnot(all(sel_props >= 0))
- stopifnot(all(sel_props <= 1))
-
- weights_i <- rep(as.numeric(NA), n_weights)
-
- # Weighted or simple average?
- if(weighting == "sparse"){
- # Sparse cluster stability selection: All features in cluster with
- # selection proportion equal to the max
- # for the cluster get equal weight; rest of cluster gets 0 weight
- if(sum(sel_props) == 0){
- weights_i <- rep(1/n_weights, n_weights)
- } else{
- maxes <- sel_props==max(sel_props)
-
- stopifnot(sum(maxes) > 0)
- stopifnot(sum(maxes) <= n_weights)
-
- weights_i <- rep(0, n_weights)
- weights_i[maxes] <- 1/sum(maxes)
- }
- } else if(weighting == "weighted_avg"){
- # Get weights for weighted average
- if(sum(sel_props) == 0){
- weights_i <- rep(1/n_weights, n_weights)
- } else{
- weights_i <- sel_props/sum(sel_props)
- }
- } else if(weighting == "simple_avg"){
- weights_i <- rep(1/n_weights, n_weights)
- } else{
- stop("weighting must be one of sparse, simple_avg, or weighted_avg")
- }
-
- stopifnot(abs(sum(weights_i) - 1) < 10^(-6))
- stopifnot(length(weights_i) == n_weights)
- stopifnot(length(weights_i) >= 1)
- stopifnot(all(weights_i >= 0))
- stopifnot(all(weights_i <= 1))
-
- return(weights_i)
-}
checkGetSelectedClustersOutput():
#' Helper function to check that output of getSelectedClusters is as expected
#'
@@ -847,109 +860,113 @@
#' combine features from the selected clusters into weighted averages, called
#' cluster representatives. Must be one of "sparse", "weighted_avg", or
#' "simple_avg". For "sparse", all the weight is put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", the weight used for each cluster member is calculated in
-#' proportion to the individual selection proportions of each feature. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, the cluster representative
-#' is just a simple average of all the cluster members). See Faletto and Bien
-#' (2022) for details. Default is "weighted_avg".
-#' @param cutoff Numeric; getCssDesign will only include those clusters with
-#' selection proportions equal to at least cutoff. Must be between 0 and 1.
-#' Default is 0 (in which case either all clusters are used, or max_num_clusts
-#' are used, if max_num_clusts is specified).
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty
-#' selection then raises an error (no design/predictions possible).
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored). Because clusters can have tied selection
-#' proportions, ties at the threshold can cause more than max_num_clusts (or
-#' fewer than min_num_clusts) clusters to be returned; when the two constraints
-#' conflict, max_num_clusts takes precedence.
-#' @return A design matrix with either nrow(newX) (or length(train_inds), if
-#' train_inds was provided to css and newX was not provided to getCssDesign)
-#' observations and number of columns equal to the number of selected clusters,
-#' containing the cluster representatives for each cluster.
-#' @author Gregory Faletto, Jacob Bien
-#' @examples
-#' set.seed(1)
-#' train <- genClusteredData(n = 50, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' newdata <- genClusteredData(n = 10, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' clusters <- list(cluster1 = 1:4)
-#' res <- css(X = train$X, y = train$y, lambda = 0.01, clusters = clusters,
-#' B = 10)
-#' X_design <- getCssDesign(res, newX = newdata$X)
-#' dim(X_design)
-#' @export
-getCssDesign <- function(css_results, newX=NA, weighting="weighted_avg",
- cutoff=0, min_num_clusts=1, max_num_clusts=NA){
- # Check inputs
- stopifnot(inherits(css_results, "cssr"))
-
- check_results <- checkNewXProvided(newX, css_results)
-
- newX <- check_results$newX
- newXProvided <- check_results$newXProvided
-
- rm(check_results)
-
- # #142: checkNewXProvided returns newX with its (already css-validated) column
- # names stripped (via checkXInputResults). Re-attach them from css_results$X
- # (which they were validated to match; ncol(newX) == ncol(css_results$X) for a
- # provided input) so the checkXInputResults call below does not spuriously warn
- # on a data.frame newX. Names never enter the numeric design.
- if(newXProvided && !is.null(colnames(css_results$X))){
- colnames(newX) <- colnames(css_results$X)
- }
-
- n_train <- nrow(newX)
-
- results <- checkXInputResults(newX, css_results$X)
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", the weight used for each cluster member is calculated in
+#' proportion to the individual selection proportions of each feature.
+#' (Exception: if no member of a selected cluster was selected on any
+#' subsample, the weights fall back to a simple average, so all of that
+#' cluster's members contribute to the representative.) For
+#' "simple_avg", each cluster member gets equal weight regardless of the
+#' individual feature selection proportions (that is, the cluster representative
+#' is just a simple average of all the cluster members). See Faletto and Bien
+#' (2022) for details. Default is "weighted_avg".
+#' @param cutoff Numeric; getCssDesign will only include those clusters with
+#' selection proportions equal to at least cutoff. Must be between 0 and 1.
+#' Default is 0 (in which case either all clusters are used, or max_num_clusts
+#' are used, if max_num_clusts is specified).
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty
+#' selection then raises an error (no design/predictions possible).
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored). Because clusters can have tied selection
+#' proportions, ties at the threshold can cause more than max_num_clusts (or
+#' fewer than min_num_clusts) clusters to be returned; when the two constraints
+#' conflict, max_num_clusts takes precedence.
+#' @return A design matrix with either nrow(newX) (or length(train_inds), if
+#' train_inds was provided to css and newX was not provided to getCssDesign)
+#' observations and number of columns equal to the number of selected clusters,
+#' containing the cluster representatives for each cluster.
+#' @author Gregory Faletto, Jacob Bien
+#' @examples
+#' set.seed(1)
+#' train <- genClusteredData(n = 50, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' newdata <- genClusteredData(n = 10, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' clusters <- list(cluster1 = 1:4)
+#' res <- css(X = train$X, y = train$y, lambda = 0.01, clusters = clusters,
+#' B = 10)
+#' X_design <- getCssDesign(res, newX = newdata$X)
+#' dim(X_design)
+#' @export
+getCssDesign <- function(css_results, newX=NA, weighting="weighted_avg",
+ cutoff=0, min_num_clusts=1, max_num_clusts=NA){
+ # Check inputs
+ stopifnot(inherits(css_results, "cssr"))
+
+ check_results <- checkNewXProvided(newX, css_results)
+
+ newX <- check_results$newX
+ newXProvided <- check_results$newXProvided
+
+ rm(check_results)
+
+ # #142: checkNewXProvided returns newX with its (already css-validated) column
+ # names stripped (via checkXInputResults). Re-attach them from css_results$X
+ # (which they were validated to match; ncol(newX) == ncol(css_results$X) for a
+ # provided input) so the checkXInputResults call below does not spuriously warn
+ # on a data.frame newX. Names never enter the numeric design.
+ if(newXProvided && !is.null(colnames(css_results$X))){
+ colnames(newX) <- colnames(css_results$X)
+ }
- newX <- results$newx
- feat_names <- results$feat_names
-
- # #142: re-attach newX's (already css-validated) column names that
- # checkXInputResults strips, so the downstream formCssDesign(newx=newX) call
- # doesn't spuriously warn on a data.frame newX. Names never enter the numeric
- # design (formCssDesign strips + builds cluster reps positionally), so this
- # only silences the warning; mirrors the getCssPreds fix.
- if(all(!is.na(feat_names))){
- colnames(newX) <- feat_names
- }
-
- rm(results)
-
- n <- nrow(newX)
- p <- ncol(newX)
-
- checkCutoff(cutoff)
- checkWeighting(weighting)
- checkMinNumClusts(min_num_clusts, p, length(css_results$clusters))
+ n_train <- nrow(newX)
+
+ results <- checkXInputResults(newX, css_results$X)
+
+ newX <- results$newx
+ feat_names <- results$feat_names
+
+ # #142: re-attach newX's (already css-validated) column names that
+ # checkXInputResults strips, so the downstream formCssDesign(newx=newX) call
+ # doesn't spuriously warn on a data.frame newX. Names never enter the numeric
+ # design (formCssDesign strips + builds cluster reps positionally), so this
+ # only silences the warning; mirrors the getCssPreds fix.
+ if(all(!is.na(feat_names))){
+ colnames(newX) <- feat_names
+ }
+
+ rm(results)
+
+ n <- nrow(newX)
+ p <- ncol(newX)
- max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p,
- length(css_results$clusters))
-
- # Take provided training design matrix and testX and turn them into
- # matrices of cluster representatives using information from css_results
- if(newXProvided){
- newX_clusters <- formCssDesign(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts, newx=newX)
- } else{
- newX_clusters <- formCssDesign(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts)
- }
-
- return(newX_clusters)
-}
#' Helper function to confirm that the new X matrix provided to getCssDesign or
#' getCssPreds matches the characteristics of the X that was provided to css.
@@ -1100,119 +1117,123 @@
#' combine features from the selected clusters into weighted averages, called
#' cluster representatives. Must be one of "sparse", "weighted_avg", or
#' "simple_avg". For "sparse", all the weight is put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", the weight used for each cluster member is calculated in
-#' proportion to the individual selection proportions of each feature. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, the cluster representative
-#' is just a simple average of all the cluster members). See Faletto and Bien
-#' (2022) for details. Default is "weighted_avg".
-#' @param cutoff Numeric; css will return only those clusters with selection
-#' proportions equal to at least cutoff. Must be between 0 and 1. Default is 0
-#' (in which case all clusters are returned in decreasing order of selection
-#' proportion).
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.) Default is 1.
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored).
-#' @param newx A numeric matrix (preferably) or a data.frame (which will
-#' be coerced internally to a matrix by the function model.matrix) containing
-#' the data that will be used to generate the design matrix of cluster
-#' representatives. Must contain the same features (in the same
-#' number of columns) as the X matrix provided to css, and if the columns of
-#' newx are labeled, the names must match the variable names provided to css.
-#' newx may be omitted if train_inds were provided to css to set aside
-#' observations for model estimation. If this is the case, then when newx is
-#' omitted formCssDesign will return a design matrix of cluster representatives
-#' formed from the train_inds observations from the matrix X provided to css.
-#' (If no train_inds were provided to css, newX must be provided to
-#' formCssDesign.) Default is NA.
-#' @return A design matrix with the same number of rows as newx (or the
-#' train_inds provided to css) where the columns are the constructed cluster
-#' representatives.
-#' @author Gregory Faletto, Jacob Bien
-#' @references
-<<faletto2022>>
-#' @keywords internal
-#' @noRd
-formCssDesign <- function(css_results, weighting="weighted_avg", cutoff=0,
- min_num_clusts=1, max_num_clusts=NA, newx=NA, weights=NULL, validated=FALSE){
-
- # Check inputs
- ret <- checkFormCssDesignInputs(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts, newx, validated = validated)
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", the weight used for each cluster member is calculated in
+#' proportion to the individual selection proportions of each feature.
+#' (Exception: if no member of a selected cluster was selected on any
+#' subsample, the weights fall back to a simple average, so all of that
+#' cluster's members contribute to the representative.) For
+#' "simple_avg", each cluster member gets equal weight regardless of the
+#' individual feature selection proportions (that is, the cluster representative
+#' is just a simple average of all the cluster members). See Faletto and Bien
+#' (2022) for details. Default is "weighted_avg".
+#' @param cutoff Numeric; css will return only those clusters with selection
+#' proportions equal to at least cutoff. Must be between 0 and 1. Default is 0
+#' (in which case all clusters are returned in decreasing order of selection
+#' proportion).
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.) Default is 1.
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored).
+#' @param newx A numeric matrix (preferably) or a data.frame (which will
+#' be coerced internally to a matrix by the function model.matrix) containing
+#' the data that will be used to generate the design matrix of cluster
+#' representatives. Must contain the same features (in the same
+#' number of columns) as the X matrix provided to css, and if the columns of
+#' newx are labeled, the names must match the variable names provided to css.
+#' newx may be omitted if train_inds were provided to css to set aside
+#' observations for model estimation. If this is the case, then when newx is
+#' omitted formCssDesign will return a design matrix of cluster representatives
+#' formed from the train_inds observations from the matrix X provided to css.
+#' (If no train_inds were provided to css, newX must be provided to
+#' formCssDesign.) Default is NA.
+#' @return A design matrix with the same number of rows as newx (or the
+#' train_inds provided to css) where the columns are the constructed cluster
+#' representatives.
+#' @author Gregory Faletto, Jacob Bien
+#' @references
+<<faletto2022>>
+#' @keywords internal
+#' @noRd
+formCssDesign <- function(css_results, weighting="weighted_avg", cutoff=0,
+ min_num_clusts=1, max_num_clusts=NA, newx=NA, weights=NULL, validated=FALSE){
- newx <- ret$newx
- max_num_clusts <- ret$max_num_clusts
-
- rm(ret)
-
- n <- nrow(newx)
- p <- ncol(newx)
-
- # Get the names of the selected clusters and the weights for the features
- # within each cluster, according to the provided weighting rule. These depend
- # only on css_results and the (weighting, cutoff, min/max_num_clusts) args,
- # NOT on newx, so a caller that forms several designs from one css_results
- # (e.g. getCssPreds, which builds a train design and a test design) can
- # compute them once and pass them in via `weights` to skip the repeated
- # getSelectedClusters() work. Byte-identical: a passed-in `weights` equals
- # what this call would otherwise recompute (checkMaxNumClusts is idempotent,
- # so the max_num_clusts re-derived by checkFormCssDesignInputs above matches
- # the caller's already-adjusted value). (#129)
- if(is.null(weights)){
- weights <- getSelectedClusters(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts)$weights
- }
-
- n_sel_clusts <- length(weights)
-
- if(n_sel_clusts == 0){
- stop("No clusters were selected, so a design matrix / predictions cannot be formed; lower the cutoff or set min_num_clusts >= 1.")
- }
+ # Check inputs
+ ret <- checkFormCssDesignInputs(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts, newx, validated = validated)
+
+ newx <- ret$newx
+ max_num_clusts <- ret$max_num_clusts
+
+ rm(ret)
+
+ n <- nrow(newx)
+ p <- ncol(newx)
+
+ # Get the names of the selected clusters and the weights for the features
+ # within each cluster, according to the provided weighting rule. These depend
+ # only on css_results and the (weighting, cutoff, min/max_num_clusts) args,
+ # NOT on newx, so a caller that forms several designs from one css_results
+ # (e.g. getCssPreds, which builds a train design and a test design) can
+ # compute them once and pass them in via `weights` to skip the repeated
+ # getSelectedClusters() work. Byte-identical: a passed-in `weights` equals
+ # what this call would otherwise recompute (checkMaxNumClusts is idempotent,
+ # so the max_num_clusts re-derived by checkFormCssDesignInputs above matches
+ # the caller's already-adjusted value). (#129)
+ if(is.null(weights)){
+ weights <- getSelectedClusters(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts)$weights
+ }
+
+ n_sel_clusts <- length(weights)
- # Form matrix of cluster representatives of selected clusters
- X_clus_reps <- matrix(rep(as.numeric(NA), n*n_sel_clusts), nrow=n,
- ncol=n_sel_clusts)
- colnames(X_clus_reps) <- rep(as.character(NA), n_sel_clusts)
-
- for(i in seq_len(n_sel_clusts)){
- clust_i_name <- names(weights)[i]
-
- stopifnot(length(clust_i_name) == 1)
- stopifnot(clust_i_name %in% names(weights))
-
- colnames(X_clus_reps)[i] <- clust_i_name
-
- clust_i <- css_results$clusters[[clust_i_name]]
+ if(n_sel_clusts == 0){
+ stop("No clusters were selected, so a design matrix / predictions cannot be formed; lower the cutoff or set min_num_clusts >= 1.")
+ }
+
+ # Form matrix of cluster representatives of selected clusters
+ X_clus_reps <- matrix(rep(as.numeric(NA), n*n_sel_clusts), nrow=n,
+ ncol=n_sel_clusts)
+ colnames(X_clus_reps) <- rep(as.character(NA), n_sel_clusts)
+
+ for(i in seq_len(n_sel_clusts)){
+ clust_i_name <- names(weights)[i]
+
+ stopifnot(length(clust_i_name) == 1)
+ stopifnot(clust_i_name %in% names(weights))
- stopifnot(length(clust_i) >= 1)
- stopifnot(all(clust_i %in% 1:p))
-
- weights_i <- weights[[clust_i_name]]
-
- stopifnot(length(clust_i) == length(weights_i))
+ colnames(X_clus_reps)[i] <- clust_i_name
+
+ clust_i <- css_results$clusters[[clust_i_name]]
+
+ stopifnot(length(clust_i) >= 1)
+ stopifnot(all(clust_i %in% 1:p))
- if(length(weights_i) > 1){
- X_clus_reps[, i] <- newx[, clust_i] %*% weights_i
- } else{
- X_clus_reps[, i] <- newx[, clust_i]*weights_i
- }
- }
-
- # Check output
- stopifnot(all(!is.na(X_clus_reps)))
- stopifnot(ncol(X_clus_reps) == n_sel_clusts)
- stopifnot(nrow(X_clus_reps) == n)
-
- return(X_clus_reps)
-}
#' Helper function to check that the inputs to formCssDesign are as expected
#'
@@ -1299,171 +1320,175 @@
#' combine features from the selected clusters into weighted averages, called
#' cluster representatives. Must be one of "sparse", "weighted_avg", or
#' "simple_avg". For "sparse", all the weight is put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", the weight used for each cluster member is calculated in
-#' proportion to the individual selection proportions of each feature. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, the cluster representative
-#' is just a simple average of all the cluster members). See Faletto and Bien
-#' (2022) for details. Default is "weighted_avg".
-#' @param cutoff Numeric; getCssPreds will make use only of those clusters with
-#' selection proportions equal to at least cutoff. Must be between 0 and 1.
-#' Default is 0 (in which case either all clusters are used, or max_num_clusts
-#' are used, if max_num_clusts is specified).
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty
-#' selection then raises an error (no design/predictions possible).
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored). Because clusters can have tied selection
-#' proportions, ties at the threshold can cause more than max_num_clusts (or
-#' fewer than min_num_clusts) clusters to be returned; when the two constraints
-#' conflict, max_num_clusts takes precedence.
-#' @param trainX A numeric matrix (preferably) or a data.frame (which will
-#' be coerced internally to a matrix by the function model.matrix) containing
-#' the data that will be used to estimate the linear model from the selected
-#' clusters. trainX is only necessary to provide if no train_inds were
-#' designated in the css function call to set aside observations for model
-#' estimation (though even if train_inds was provided, trainX and trainY will be
-#' used for model estimation if they are both provided to getCssPreds). Must
-#' contain the same features (in the same number of columns) as the matrix
-#' provided to css, and if the columns of trainX are labeled, the names must
-#' match the variable names provided to css. Must not contain missing (`NA`)
-#' values. Default is NA (in which case getCssPreds uses the observations from
-#' the train_inds that were provided to css to estimate a linear model).
-#' @param trainY The response corresponding to trainX. Must be a real-valued
-#' response (unlike in the general css setup) because predictions will be
-#' generated by an ordinary least squares model. Must have the same length as
-#' the number of rows of trainX. Like trainX, only needs to be provided if no
-#' observations were set aside for model estimation by the parameter train_inds
-#' in the css function call. Default is NA (in which case getCssPreds uses the
-#' observations from the train_inds that were provided to css).
-#' @return A vector of predictions corresponding to the observations from testX.
-#' @author Gregory Faletto, Jacob Bien
-#' @references
-<<faletto2022>>
-#' @examples
-#' set.seed(1)
-#' data <- genClusteredData(n = 60, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' clusters <- list(cluster1 = 1:4)
-#' # Split into selection / training / test rows.
-#' res <- css(X = data$X[1:20, ], y = data$y[1:20], lambda = 0.01,
-#' clusters = clusters, B = 10)
-#' preds <- getCssPreds(res, testX = data$X[51:60, ],
-#' trainX = data$X[21:50, ], trainY = data$y[21:50])
-#' preds
-#' @export
-getCssPreds <- function(css_results, testX, weighting="weighted_avg", cutoff=0,
- min_num_clusts=1, max_num_clusts=NA, trainX=NA, trainY=NA){
- # Check inputs
-
- check_list <- checkGetCssPredsInputs(css_results, testX, weighting, cutoff,
- min_num_clusts, max_num_clusts, trainX, trainY)
-
- trainXProvided <- check_list$trainXProvided
- trainX <- check_list$trainX
- testX <- check_list$testX
- feat_names <- check_list$feat_names
- max_num_clusts <- check_list$max_num_clusts
-
- rm(check_list)
-
- n_train <- nrow(trainX)
- n <- nrow(testX)
- p <- ncol(testX)
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", the weight used for each cluster member is calculated in
+#' proportion to the individual selection proportions of each feature.
+#' (Exception: if no member of a selected cluster was selected on any
+#' subsample, the weights fall back to a simple average, so all of that
+#' cluster's members contribute to the representative.) For
+#' "simple_avg", each cluster member gets equal weight regardless of the
+#' individual feature selection proportions (that is, the cluster representative
+#' is just a simple average of all the cluster members). See Faletto and Bien
+#' (2022) for details. Default is "weighted_avg".
+#' @param cutoff Numeric; getCssPreds will make use only of those clusters with
+#' selection proportions equal to at least cutoff. Must be between 0 and 1.
+#' Default is 0 (in which case either all clusters are used, or max_num_clusts
+#' are used, if max_num_clusts is specified).
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.) Default is 1. May be 0, but an empty
+#' selection then raises an error (no design/predictions possible).
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored). Because clusters can have tied selection
+#' proportions, ties at the threshold can cause more than max_num_clusts (or
+#' fewer than min_num_clusts) clusters to be returned; when the two constraints
+#' conflict, max_num_clusts takes precedence.
+#' @param trainX A numeric matrix (preferably) or a data.frame (which will
+#' be coerced internally to a matrix by the function model.matrix) containing
+#' the data that will be used to estimate the linear model from the selected
+#' clusters. trainX is only necessary to provide if no train_inds were
+#' designated in the css function call to set aside observations for model
+#' estimation (though even if train_inds was provided, trainX and trainY will be
+#' used for model estimation if they are both provided to getCssPreds). Must
+#' contain the same features (in the same number of columns) as the matrix
+#' provided to css, and if the columns of trainX are labeled, the names must
+#' match the variable names provided to css. Must not contain missing (`NA`)
+#' values. Default is NA (in which case getCssPreds uses the observations from
+#' the train_inds that were provided to css to estimate a linear model).
+#' @param trainY The response corresponding to trainX. Must be a real-valued
+#' response (unlike in the general css setup) because predictions will be
+#' generated by an ordinary least squares model. Must have the same length as
+#' the number of rows of trainX. Like trainX, only needs to be provided if no
+#' observations were set aside for model estimation by the parameter train_inds
+#' in the css function call. Default is NA (in which case getCssPreds uses the
+#' observations from the train_inds that were provided to css).
+#' @return A vector of predictions corresponding to the observations from testX.
+#' @author Gregory Faletto, Jacob Bien
+#' @references
+<<faletto2022>>
+#' @examples
+#' set.seed(1)
+#' data <- genClusteredData(n = 60, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' clusters <- list(cluster1 = 1:4)
+#' # Split into selection / training / test rows.
+#' res <- css(X = data$X[1:20, ], y = data$y[1:20], lambda = 0.01,
+#' clusters = clusters, B = 10)
+#' preds <- getCssPreds(res, testX = data$X[51:60, ],
+#' trainX = data$X[21:50, ], trainY = data$y[21:50])
+#' preds
+#' @export
+getCssPreds <- function(css_results, testX, weighting="weighted_avg", cutoff=0,
+ min_num_clusts=1, max_num_clusts=NA, trainX=NA, trainY=NA){
+ # Check inputs
+
+ check_list <- checkGetCssPredsInputs(css_results, testX, weighting, cutoff,
+ min_num_clusts, max_num_clusts, trainX, trainY)
+
+ trainXProvided <- check_list$trainXProvided
+ trainX <- check_list$trainX
+ testX <- check_list$testX
+ feat_names <- check_list$feat_names
+ max_num_clusts <- check_list$max_num_clusts
+
+ rm(check_list)
- # The cluster weights depend only on css_results and the (weighting, cutoff,
- # min/max_num_clusts) arguments -- not on the design matrix -- so compute
- # them ONCE here and reuse for every formCssDesign() call below (train +
- # test) instead of letting each call recompute the same getSelectedClusters()
- # (colMeans + cutoff loops + getAllClustWeights). max_num_clusts is already
- # checkMaxNumClusts-adjusted by checkGetCssPredsInputs, and checkMaxNumClusts
- # is idempotent, so these weights are byte-identical to what each
- # formCssDesign() would otherwise compute internally. (#129)
- sel_weights <- getSelectedClusters(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts)$weights
-
- # Take provided training design matrix and testX and turn them into
- # matrices of cluster representatives using information from css_results
- if(trainXProvided){
- train_X_clusters <- formCssDesign(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts, newx=trainX, weights=sel_weights,
- validated=TRUE)
- if(!is.numeric(trainY) & !is.integer(trainY)){
- stop("The provided trainY must be real-valued, because predictions will be generated by ordinary least squares regression.")
- }
- y_train <- trainY
- } else{
- train_X_clusters <- formCssDesign(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts, weights=sel_weights,
- validated=TRUE)
- y_train <- css_results$y[css_results$train_inds]
- if(!is.numeric(y_train) & !is.integer(y_train)){
- stop("Can't generate predictions from the data that was provided to css because the provided y was not real-valued (getCssPreds generated predictions using ordinary least squares regression).")
- }
- }
-
- stopifnot(length(y_train) == nrow(train_X_clusters))
-
- testX_clusters <- formCssDesign(css_results, weighting, cutoff,
- min_num_clusts, max_num_clusts, newx=testX, weights=sel_weights,
- validated=TRUE)
+ n_train <- nrow(trainX)
+ n <- nrow(testX)
+ p <- ncol(testX)
+
+ # The cluster weights depend only on css_results and the (weighting, cutoff,
+ # min/max_num_clusts) arguments -- not on the design matrix -- so compute
+ # them ONCE here and reuse for every formCssDesign() call below (train +
+ # test) instead of letting each call recompute the same getSelectedClusters()
+ # (colMeans + cutoff loops + getAllClustWeights). max_num_clusts is already
+ # checkMaxNumClusts-adjusted by checkGetCssPredsInputs, and checkMaxNumClusts
+ # is idempotent, so these weights are byte-identical to what each
+ # formCssDesign() would otherwise compute internally. (#129)
+ sel_weights <- getSelectedClusters(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts)$weights
+
+ # Take provided training design matrix and testX and turn them into
+ # matrices of cluster representatives using information from css_results
+ if(trainXProvided){
+ train_X_clusters <- formCssDesign(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts, newx=trainX, weights=sel_weights,
+ validated=TRUE)
+ if(!is.numeric(trainY) & !is.integer(trainY)){
+ stop("The provided trainY must be real-valued, because predictions will be generated by ordinary least squares regression.")
+ }
+ y_train <- trainY
+ } else{
+ train_X_clusters <- formCssDesign(css_results, weighting, cutoff,
+ min_num_clusts, max_num_clusts, weights=sel_weights,
+ validated=TRUE)
+ y_train <- css_results$y[css_results$train_inds]
+ if(!is.numeric(y_train) & !is.integer(y_train)){
+ stop("Can't generate predictions from the data that was provided to css because the provided y was not real-valued (getCssPreds generated predictions using ordinary least squares regression).")
+ }
+ }
+
+ stopifnot(length(y_train) == nrow(train_X_clusters))
- stopifnot(ncol(testX_clusters) == ncol(train_X_clusters))
-
- # Get names for clusters
- clust_X_names <- paste("c_fit_", 1:ncol(testX_clusters), sep="")
- if(!is.null(colnames(train_X_clusters))){
- stopifnot(identical(colnames(train_X_clusters), colnames(testX_clusters)))
- clust_X_names <- colnames(train_X_clusters)
- }
-
- # Fit linear model on training data via OLS. lm(y ~ .) adds an intercept, so
- # the fit is rank-deficient unless there are strictly more training
- # observations than clusters (nrow >= ncol + 1); guard with <= so the
- # n_train == n_clusters boundary errors clearly instead of silently fitting a
- # rank-deficient model with NA coefficients.
- if(nrow(train_X_clusters) <= ncol(train_X_clusters)){
- err_mess <- paste("css not provided with enough indices to fit OLS model for predictions (number of training indices: ",
- nrow(train_X_clusters), ", number of clusters: ",
- ncol(train_X_clusters),
- "). The OLS model includes an intercept, so it needs at least one more training observation than the number of clusters. Try reducing number of clusters by increasing cutoff, or re-run css with a larger number of training indices.",
- sep="")
- stop(err_mess)
- }
-
- # Response name guaranteed distinct from every cluster name (issue #150):
- # make.unique returns "y" when no cluster is named "y" (bit-identical to
- # prior behavior) and e.g. "y.1" when one is, so lm() never drops a
- # cluster representative via a name collision with the response.
- resp_name <- make.unique(c(clust_X_names, "y"))[length(clust_X_names) + 1L]
- df <- data.frame(y_train, train_X_clusters)
- colnames(df) <- c(resp_name, clust_X_names)
- stopifnot(!anyDuplicated(colnames(df)))
- model <- stats::lm(stats::as.formula(paste0("`", resp_name, "` ~ .")), data = df)
-
- # Use fitted model to generate predictions on testX. Route through
- # olsPredictRankSafe() so a rank-deficient OLS fit predicts from its
- # estimable coefficients instead of crashing under R >= 4.4's predict.lm
- # default (see the helper's note and issue #117).
- df_test <- data.frame(testX_clusters)
- colnames(df_test) <- clust_X_names
- predictions <- olsPredictRankSafe(model, df_test)
- names(predictions) <- NULL
-
- # Check output
- stopifnot(is.numeric(predictions) | is.integer(predictions))
- stopifnot(length(predictions) == n)
- stopifnot(all(is.finite(predictions)))
-
- return(predictions)
-}
Internal OLS-prediction helper used by getCssPreds() (issue #117):
#' Predict from a possibly rank-deficient OLS fit without crashing on R >= 4.4
#'
@@ -1509,156 +1534,160 @@
#' combine features from the selected clusters into weighted averages, called
#' cluster representatives. Must be one of "sparse", "weighted_avg", or
#' "simple_avg". For "sparse", all the weight is put on the most frequently
-#' selected individual cluster member (or divided equally among all the clusters
-#' that are tied for the top selection proportion if there is a tie). For
-#' "weighted_avg", the weight used for each cluster member is calculated in
-#' proportion to the individual selection proportions of each feature. For
-#' "simple_avg", each cluster member gets equal weight regardless of the
-#' individual feature selection proportions (that is, the cluster representative
-#' is just a simple average of all the cluster members). See Faletto and Bien
-#' (2022) for details. Default is "weighted_avg".
-#' @param cutoff Numeric; getCssPreds will make use only of those clusters with
-#' selection proportions equal to at least cutoff. Must be between 0 and 1.
-#' Default is 0 (in which case either all clusters are used, or max_num_clusts
-#' are used, if max_num_clusts is specified).
-#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
-#' min_num_clusts clusters, the cutoff will be lowered until at least
-#' min_num_clusts clusters are selected.) Default is 1.
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored).
-#' @param trainX A numeric matrix (preferably) or a data.frame (which will
-#' be coerced internally to a matrix by the function model.matrix) containing
-#' the data that will be used to estimate the linear model from the selected
-#' clusters. trainX is only necessary to provide if no train_inds were
-#' designated in the css function call to set aside observations for model
-#' estimation (though even if train_inds was provided, trainX and trainY will be
-#' used for model estimation if they are both provided to getCssPreds). Must
-#' contain the same features (in the same number of columns) as the matrix
-#' provided to css, and if the columns of trainX are labeled, the names must
-#' match the variable names provided to css. Must not contain missing (`NA`)
-#' values. Default is NA (in which case getCssPreds uses the observations from
-#' the train_inds that were provided to css to estimate a linear model).
-#' @param trainY The response corresponding to trainX. Must be a real-valued
-#' response (unlike in the general css setup) because predictions will be
-#' generated by an ordinary least squares model. Must have the same length as
-#' the number of rows of trainX. Like trainX, only needs to be provided if no
-#' observations were set aside for model estimation by the parameter train_inds
-#' in the css function call. Default is NA (in which case getCssPreds uses the
-#' observations from the train_inds that were provided to css).
-#' @return A named list with the following elements: \item{trainXProvided}{
-#' Logical; indicates whether a valid trainX input was provided.} \item{trainX}{
-#' The provided trainX matrix, coerced from a data.frame to a matrix if the
-#' provided trainX was a data.frame. (If a valid trainX was not provided, this
-#' output simply passes whatever was provided as trainX.)} \item{testX}{The
-#' provided testX matrix, coerced from a data.frame to a matrix if the provided
-#' testX was a data.frame.} \item{feat_names}{A character vector containing the
-#' column names of testX (if the provided testX had column names). If the
-#' provided testX did not have column names, feat_names will be NA.}
-#' \item{max_num_clusts}{The provided max_num_clusts, coerced to an integer if
-#' needed, and coerced to be less than or equal to the total number of clusters
-#' from the output of css_results.}
-#' @author Gregory Faletto, Jacob Bien
-#' @keywords internal
-#' @noRd
-checkGetCssPredsInputs <- function(css_results, testX, weighting, cutoff,
- min_num_clusts, max_num_clusts, trainX, trainY){
- # Check inputs
- stopifnot(inherits(css_results, "cssr"))
-
- check_results <- checkNewXProvided(trainX, css_results)
-
- trainX <- check_results$newX
- trainXProvided <- check_results$newXProvided
- trainX_feat_names <- check_results$feat_names
+#' selected individual cluster member (or divided equally among all the
+#' cluster members that are tied for the top selection proportion if there is
+#' a tie). For
+#' "weighted_avg", the weight used for each cluster member is calculated in
+#' proportion to the individual selection proportions of each feature.
+#' (Exception: if no member of a selected cluster was selected on any
+#' subsample, the weights fall back to a simple average, so all of that
+#' cluster's members contribute to the representative.) For
+#' "simple_avg", each cluster member gets equal weight regardless of the
+#' individual feature selection proportions (that is, the cluster representative
+#' is just a simple average of all the cluster members). See Faletto and Bien
+#' (2022) for details. Default is "weighted_avg".
+#' @param cutoff Numeric; getCssPreds will make use only of those clusters with
+#' selection proportions equal to at least cutoff. Must be between 0 and 1.
+#' Default is 0 (in which case either all clusters are used, or max_num_clusts
+#' are used, if max_num_clusts is specified).
+#' @param min_num_clusts Integer or numeric; the minimum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns fewer than
+#' min_num_clusts clusters, the cutoff will be lowered until at least
+#' min_num_clusts clusters are selected.) Default is 1.
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored).
+#' @param trainX A numeric matrix (preferably) or a data.frame (which will
+#' be coerced internally to a matrix by the function model.matrix) containing
+#' the data that will be used to estimate the linear model from the selected
+#' clusters. trainX is only necessary to provide if no train_inds were
+#' designated in the css function call to set aside observations for model
+#' estimation (though even if train_inds was provided, trainX and trainY will be
+#' used for model estimation if they are both provided to getCssPreds). Must
+#' contain the same features (in the same number of columns) as the matrix
+#' provided to css, and if the columns of trainX are labeled, the names must
+#' match the variable names provided to css. Must not contain missing (`NA`)
+#' values. Default is NA (in which case getCssPreds uses the observations from
+#' the train_inds that were provided to css to estimate a linear model).
+#' @param trainY The response corresponding to trainX. Must be a real-valued
+#' response (unlike in the general css setup) because predictions will be
+#' generated by an ordinary least squares model. Must have the same length as
+#' the number of rows of trainX. Like trainX, only needs to be provided if no
+#' observations were set aside for model estimation by the parameter train_inds
+#' in the css function call. Default is NA (in which case getCssPreds uses the
+#' observations from the train_inds that were provided to css).
+#' @return A named list with the following elements: \item{trainXProvided}{
+#' Logical; indicates whether a valid trainX input was provided.} \item{trainX}{
+#' The provided trainX matrix, coerced from a data.frame to a matrix if the
+#' provided trainX was a data.frame. (If a valid trainX was not provided, this
+#' output simply passes whatever was provided as trainX.)} \item{testX}{The
+#' provided testX matrix, coerced from a data.frame to a matrix if the provided
+#' testX was a data.frame.} \item{feat_names}{A character vector containing the
+#' column names of testX (if the provided testX had column names). If the
+#' provided testX did not have column names, feat_names will be NA.}
+#' \item{max_num_clusts}{The provided max_num_clusts, coerced to an integer if
+#' needed, and coerced to be less than or equal to the total number of clusters
+#' from the output of css_results.}
+#' @author Gregory Faletto, Jacob Bien
+#' @keywords internal
+#' @noRd
+checkGetCssPredsInputs <- function(css_results, testX, weighting, cutoff,
+ min_num_clusts, max_num_clusts, trainX, trainY){
+ # Check inputs
+ stopifnot(inherits(css_results, "cssr"))
+
+ check_results <- checkNewXProvided(trainX, css_results)
- rm(check_results)
-
- n_train <- nrow(trainX)
+ trainX <- check_results$newX
+ trainXProvided <- check_results$newXProvided
+ trainX_feat_names <- check_results$feat_names
- # #153d: distinguish an omitted trainY (documented scalar-NA default) from a
- # trainY that was PROVIDED but invalid (contains NA). The former falls back
- # to css's train_inds; the latter must error rather than silently switch the
- # data the model is fit on.
- trainYProvided <- !(is.atomic(trainY) && length(trainY) == 1 && is.na(trainY))
- if(trainXProvided){
- if(trainYProvided){
- stopifnot(is.numeric(trainY))
- if(any(is.na(trainY))){
- stop("The provided trainY contains missing (NA) values; trainY must be a complete real-valued response with one value per row of trainX.")
- }
- stopifnot(n_train == length(trainY))
- } else{
- if(length(css_results$train_inds) == 0){
- stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions")
- }
- trainXProvided <- FALSE
- warning("trainX provided but no trainY provided; instead, training model using the train_inds observations provided to css to set aside for model training.")
- }
- } else{
- if(length(css_results$train_inds) == 0){
- stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions")
+ rm(check_results)
+
+ n_train <- nrow(trainX)
+
+ # #153d: distinguish an omitted trainY (documented scalar-NA default) from a
+ # trainY that was PROVIDED but invalid (contains NA). The former falls back
+ # to css's train_inds; the latter must error rather than silently switch the
+ # data the model is fit on.
+ trainYProvided <- !(is.atomic(trainY) && length(trainY) == 1 && is.na(trainY))
+ if(trainXProvided){
+ if(trainYProvided){
+ stopifnot(is.numeric(trainY))
+ if(any(is.na(trainY))){
+ stop("The provided trainY contains missing (NA) values; trainY must be a complete real-valued response with one value per row of trainX.")
+ }
+ stopifnot(n_train == length(trainY))
+ } else{
+ if(length(css_results$train_inds) == 0){
+ stop("css was not provided with indices to set aside for model training (train_inds), so must provide both trainX and trainY in order to generate predictions")
+ }
+ trainXProvided <- FALSE
+ warning("trainX provided but no trainY provided; instead, training model using the train_inds observations provided to css to set aside for model training.")
}
- if(trainYProvided){
- warning("trainY provided but no trainX provided; instead, training model using the train_inds observations provided to css to set aside for model training.")
- }
- }
-
- results <- checkXInputResults(testX, css_results$X)
-
- testX <- results$newx
- feat_names <- results$feat_names
-
- if(all(!is.na(feat_names))){
- stopifnot(length(feat_names) == ncol(testX))
- stopifnot(!("(Intercept)" %in% feat_names))
- colnames(testX) <- feat_names
- }
-
- rm(results)
-
- n <- nrow(testX)
- p <- ncol(testX)
-
- stopifnot(n >= 1)
- stopifnot(p == ncol(trainX))
- # #153a: restore trainX's OWN validated names (checkNewXProvided strips them),
- # from the css object, independently of testX. The old #142 code derived them
- # from testX, so a named trainX + unnamed testX stayed name-less and tripped a
- # spurious downstream "no variable names" warning about a matrix the user named.
- if(trainXProvided && all(!is.na(trainX_feat_names))){
- colnames(trainX) <- colnames(css_results$X)
- }
- # #153c: only compare names when trainX was USER-provided. Guarding here both
- # revives the previously-dead "testX but not trainX" branch (the old #142
- # code always re-named trainX from testX, making it unsatisfiable) and
- # suppresses a false "trainX but not testX" warning on the train_inds default
- # path (where trainX is the internally-formed, unnamed train set).
- if(trainXProvided){
- if(!is.null(colnames(trainX)) & is.null(colnames(testX))){
- warning("Column names were provided for trainX but not for testX (are you sure they both contain identical features in the same order?)")
- }
- if(is.null(colnames(trainX)) & !is.null(colnames(testX))){
- warning("Column names were provided for testX but not for trainX (are you sure they both contain identical features in the same order?)")
- }
- if(!is.null(colnames(trainX)) & !is.null(colnames(testX))){
- stopifnot(all(colnames(trainX) == colnames(testX)))
- }
- }
-
- checkCutoff(cutoff)
- checkWeighting(weighting)
- checkMinNumClusts(min_num_clusts, p, length(css_results$clusters))
- max_num_clusts <- checkMaxNumClusts(max_num_clusts, min_num_clusts, p,
- length(css_results$clusters))
-
- return(list(trainXProvided=trainXProvided, trainX=trainX, testX=testX,
- feat_names=feat_names, max_num_clusts=max_num_clusts))
-
-}
Tests for processClusterLassoInputs():
testthat::test_that("processClusterLassoInputs works", {
- set.seed(82612)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- ret <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("x", "clusters", "prototypes",
- "var_names"))
-
- # X
- testthat::expect_true(is.matrix(ret$x))
- testthat::expect_true(all(!is.na(ret$x)))
- testthat::expect_true(is.numeric(ret$x))
- testthat::expect_equal(ncol(ret$x), 11)
- testthat::expect_equal(nrow(ret$x), 15)
- testthat::expect_true(all(abs(ret$x - x) < 10^(-9)))
-
- # clusters
- testthat::expect_true(is.list(ret$clusters))
- testthat::expect_equal(length(ret$clusters), 5)
- testthat::expect_equal(5, length(names(ret$clusters)))
- testthat::expect_equal(5, length(unique(names(ret$clusters))))
- testthat::expect_true("red_cluster" %in% names(ret$clusters))
- testthat::expect_true("green_cluster" %in% names(ret$clusters))
- testthat::expect_true(all(!is.na(names(ret$clusters))))
- testthat::expect_true(all(!is.null(names(ret$clusters))))
- testthat::expect_true(all(names(ret$clusters) != ""))
-
- clust_feats <- integer()
- true_list <- list(1:4, 5:8, 9, 10, 11)
- for(i in 1:length(ret$clusters)){
- testthat::expect_true(is.integer(ret$clusters[[i]]))
- testthat::expect_equal(length(intersect(clust_feats, ret$clusters[[i]])), 0)
- testthat::expect_true(all(ret$clusters[[i]] %in% 1:11))
- testthat::expect_equal(length(ret$clusters[[i]]),
- length(unique(ret$clusters[[i]])))
- testthat::expect_true(all(ret$clusters[[i]] == true_list[[i]]))
- clust_feats <- c(clust_feats, ret$clusters[[i]])
- }
-
- testthat::expect_equal(length(clust_feats), 11)
- testthat::expect_equal(11, length(unique(clust_feats)))
- testthat::expect_equal(11, length(intersect(clust_feats, 1:11)))
-
- # prototypes
- testthat::expect_true(is.integer(ret$prototypes))
- testthat::expect_true(all(ret$prototypes %in% 1:11))
- testthat::expect_equal(length(ret$prototypes), 5)
- testthat::expect_true(ret$prototypes[1] %in% 1:4)
- testthat::expect_true(ret$prototypes[2] %in% 5:8)
- testthat::expect_equal(ret$prototypes[3], 9)
- testthat::expect_equal(ret$prototypes[4], 10)
- testthat::expect_equal(ret$prototypes[5], 11)
-
- # var_names
- testthat::expect_equal(length(ret$var_names), 1)
- testthat::expect_true(is.na(ret$var_names))
-
- # X as a data.frame
- X_df <- datasets::mtcars
- res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
- clusters=1:3, nlambda=10)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("x", "clusters", "prototypes",
- "var_names"))
-
- X_df_model <- stats::model.matrix(~ ., X_df)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- # X
- testthat::expect_true(is.matrix(res$x))
- testthat::expect_true(all(!is.na(res$x)))
- testthat::expect_true(is.numeric(res$x))
- testthat::expect_equal(ncol(res$x), ncol(X_df_model))
- testthat::expect_equal(nrow(res$x), nrow(X_df))
- testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9)))
-
- # var_names
- testthat::expect_equal(length(res$var_names), ncol(X_df_model))
- testthat::expect_true(is.character(res$var_names))
- testthat::expect_identical(res$var_names, colnames(X_df_model))
-
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- # Should get error if I try to use clusters because df2 contains factors with
- # more than two levels
- testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
- clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.",
- fixed=TRUE)
-
- # Should be fine with no clusters
- res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
- clusters=list(), nlambda=10)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("x", "clusters", "prototypes",
- "var_names"))
-
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- # X
- testthat::expect_true(is.matrix(res$x))
- testthat::expect_true(all(!is.na(res$x)))
- testthat::expect_true(is.numeric(res$x))
- testthat::expect_equal(ncol(res$x), ncol(X_df_model))
- testthat::expect_equal(nrow(res$x), nrow(X_df))
- testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9)))
-
- # var_names
- testthat::expect_equal(length(res$var_names), ncol(X_df_model))
- testthat::expect_true(is.character(res$var_names))
- testthat::expect_identical(res$var_names, colnames(X_df_model))
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("x", "clusters", "prototypes",
- "var_names"))
-
- # X
- testthat::expect_true(is.matrix(ret$x))
- testthat::expect_true(all(!is.na(ret$x)))
- testthat::expect_true(is.numeric(ret$x))
- testthat::expect_equal(ncol(ret$x), 11)
- testthat::expect_equal(nrow(ret$x), 15)
- testthat::expect_true(all(abs(ret$x - x) < 10^(-9)))
-
- # var_names
- testthat::expect_equal(length(ret$var_names), ncol(x2))
- testthat::expect_true(is.character(ret$var_names))
- testthat::expect_identical(ret$var_names, LETTERS[1:11])
-
- # Bad inputs
- testthat::expect_error(processClusterLassoInputs(X="x", y=y[1:10],
- clusters=good_clusters,
- nlambda=10),
- "is.matrix(X) | is.data.frame(X) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y[1:10],
- clusters=good_clusters,
- nlambda=10),
- "n == length(y) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=list(1:4, 4:6),
- nlambda=10),
- "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.",
- fixed=TRUE)
-
- # Duplicate clusters are now silently removed (#156): identical to passing the
- # cluster once (processClusterLassoInputs is deterministic here).
- testthat::expect_identical(processClusterLassoInputs(X=x, y=y,
- clusters=list(2:3, 2:3),
- nlambda=10),
- processClusterLassoInputs(X=x, y=y,
- clusters=list(2:3),
- nlambda=10))
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=list(1:4,
- as.integer(NA)),
- nlambda=10),
- "!is.na(clusters) are not all TRUE",
- fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=list(2:3,
- c(4, 4, 5)),
- nlambda=10),
- "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=good_clusters,
- nlambda=1),
- "nlambda >= 2 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=good_clusters,
- nlambda=x),
- "length(nlambda) == 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=good_clusters,
- nlambda="nlambda"),
- "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(processClusterLassoInputs(X=x, y=y,
- clusters=good_clusters,
- nlambda=10.5),
- "nlambda == round(nlambda) is not TRUE",
- fixed=TRUE)
-
-})## Test passed with 99 successes.Tests for checkGetXglmnetInputs():
testthat::test_that("checkGetXglmnetInputs works", {
+testthat::test_that("processClusterLassoInputs works", {
set.seed(82612)
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
y <- stats::rnorm(15)
good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
- nlambda=10)
-
- checkGetXglmnetInputs(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
+
+ ret <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters, nlambda=10)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("x", "clusters", "prototypes",
+ "var_names"))
- checkGetXglmnetInputs(x=process$x, clusters=process$clusters,
- type="clusterRepLasso",
- prototypes=process$prototypes)
-
- # X as a data.frame
- X_df <- datasets::mtcars
- res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
- clusters=1:3, nlambda=10)
-
- checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="clusterRepLasso",
- prototypes=res$prototypes)
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- # Should get an error if clusters are provided since df2 contains factors
- # with more than two levels
- testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
- clusters=1:3, nlambda=10),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
-
- # Should be fine if no clusters are provided
- res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
- clusters=list(), nlambda=10)
-
- checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="protolasso",
- prototypes=res$prototypes)
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10)
-
- checkGetXglmnetInputs(x=ret$x, clusters=ret$clusters, type="clusterRepLasso",
- prototypes=ret$prototypes)
-
- # Bad prototype inputs
- # Error has quotation marks
- testthat::expect_error(checkGetXglmnetInputs(x=process$x,
- clusters=process$clusters,
- type="clsterRepLasso",
- prototypes=process$prototypes))
-
- testthat::expect_error(checkGetXglmnetInputs(x=process$x,
- clusters=process$clusters,
- type=c("clusterRepLasso",
- "protolasso"),
- prototypes=process$prototypes),
- "length(type) == 1 is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGetXglmnetInputs(x=process$x,
- clusters=process$clusters,
- type=2,
- prototypes=process$prototypes),
- "is.character(type) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGetXglmnetInputs(x=process$x,
- clusters=process$clusters,
- type=as.character(NA),
- prototypes=process$prototypes),
- "!is.na(type) is not TRUE",
- fixed=TRUE)
-
-})
-## Test passed with 5 successes.
-Tests for getXglmnet():
-testthat::test_that("getXglmnet works", {
+ # X
+ testthat::expect_true(is.matrix(ret$x))
+ testthat::expect_true(all(!is.na(ret$x)))
+ testthat::expect_true(is.numeric(ret$x))
+ testthat::expect_equal(ncol(ret$x), 11)
+ testthat::expect_equal(nrow(ret$x), 15)
+ testthat::expect_true(all(abs(ret$x - x) < 10^(-9)))
+
+ # clusters
+ testthat::expect_true(is.list(ret$clusters))
+ testthat::expect_equal(length(ret$clusters), 5)
+ testthat::expect_equal(5, length(names(ret$clusters)))
+ testthat::expect_equal(5, length(unique(names(ret$clusters))))
+ testthat::expect_true("red_cluster" %in% names(ret$clusters))
+ testthat::expect_true("green_cluster" %in% names(ret$clusters))
+ testthat::expect_true(all(!is.na(names(ret$clusters))))
+ testthat::expect_true(all(!is.null(names(ret$clusters))))
+ testthat::expect_true(all(names(ret$clusters) != ""))
+
+ clust_feats <- integer()
+ true_list <- list(1:4, 5:8, 9, 10, 11)
+ for(i in 1:length(ret$clusters)){
+ testthat::expect_true(is.integer(ret$clusters[[i]]))
+ testthat::expect_equal(length(intersect(clust_feats, ret$clusters[[i]])), 0)
+ testthat::expect_true(all(ret$clusters[[i]] %in% 1:11))
+ testthat::expect_equal(length(ret$clusters[[i]]),
+ length(unique(ret$clusters[[i]])))
+ testthat::expect_true(all(ret$clusters[[i]] == true_list[[i]]))
+ clust_feats <- c(clust_feats, ret$clusters[[i]])
+ }
+
+ testthat::expect_equal(length(clust_feats), 11)
+ testthat::expect_equal(11, length(unique(clust_feats)))
+ testthat::expect_equal(11, length(intersect(clust_feats, 1:11)))
+
+ # prototypes
+ testthat::expect_true(is.integer(ret$prototypes))
+ testthat::expect_true(all(ret$prototypes %in% 1:11))
+ testthat::expect_equal(length(ret$prototypes), 5)
+ testthat::expect_true(ret$prototypes[1] %in% 1:4)
+ testthat::expect_true(ret$prototypes[2] %in% 5:8)
+ testthat::expect_equal(ret$prototypes[3], 9)
+ testthat::expect_equal(ret$prototypes[4], 10)
+ testthat::expect_equal(ret$prototypes[5], 11)
+
+ # var_names
+ testthat::expect_equal(length(ret$var_names), 1)
+ testthat::expect_true(is.na(ret$var_names))
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+ res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
+ clusters=1:3, nlambda=10)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("x", "clusters", "prototypes",
+ "var_names"))
+
+ X_df_model <- stats::model.matrix(~ ., X_df)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ # X
+ testthat::expect_true(is.matrix(res$x))
+ testthat::expect_true(all(!is.na(res$x)))
+ testthat::expect_true(is.numeric(res$x))
+ testthat::expect_equal(ncol(res$x), ncol(X_df_model))
+ testthat::expect_equal(nrow(res$x), nrow(X_df))
+ testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9)))
+
+ # var_names
+ testthat::expect_equal(length(res$var_names), ncol(X_df_model))
+ testthat::expect_true(is.character(res$var_names))
+ testthat::expect_identical(res$var_names, colnames(X_df_model))
+
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ # Should get error if I try to use clusters because df2 contains factors with
+ # more than two levels
+ testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
+ clusters=1:3, nlambda=10), "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.",
+ fixed=TRUE)
+
+ # Should be fine with no clusters
+ res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
+ clusters=list(), nlambda=10)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("x", "clusters", "prototypes",
+ "var_names"))
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ # X
+ testthat::expect_true(is.matrix(res$x))
+ testthat::expect_true(all(!is.na(res$x)))
+ testthat::expect_true(is.numeric(res$x))
+ testthat::expect_equal(ncol(res$x), ncol(X_df_model))
+ testthat::expect_equal(nrow(res$x), nrow(X_df))
+ testthat::expect_true(all(abs(res$x - X_df_model) < 10^(-9)))
+
+ # var_names
+ testthat::expect_equal(length(res$var_names), ncol(X_df_model))
+ testthat::expect_true(is.character(res$var_names))
+ testthat::expect_identical(res$var_names, colnames(X_df_model))
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("x", "clusters", "prototypes",
+ "var_names"))
+
+ # X
+ testthat::expect_true(is.matrix(ret$x))
+ testthat::expect_true(all(!is.na(ret$x)))
+ testthat::expect_true(is.numeric(ret$x))
+ testthat::expect_equal(ncol(ret$x), 11)
+ testthat::expect_equal(nrow(ret$x), 15)
+ testthat::expect_true(all(abs(ret$x - x) < 10^(-9)))
+
+ # var_names
+ testthat::expect_equal(length(ret$var_names), ncol(x2))
+ testthat::expect_true(is.character(ret$var_names))
+ testthat::expect_identical(ret$var_names, LETTERS[1:11])
+
+ # Bad inputs
+ testthat::expect_error(processClusterLassoInputs(X="x", y=y[1:10],
+ clusters=good_clusters,
+ nlambda=10),
+ "is.matrix(X) | is.data.frame(X) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y[1:10],
+ clusters=good_clusters,
+ nlambda=10),
+ "n == length(y) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=list(1:4, 4:6),
+ nlambda=10),
+ "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.",
+ fixed=TRUE)
+
+ # Duplicate clusters are now silently removed (#156): identical to passing the
+ # cluster once (processClusterLassoInputs is deterministic here).
+ testthat::expect_identical(processClusterLassoInputs(X=x, y=y,
+ clusters=list(2:3, 2:3),
+ nlambda=10),
+ processClusterLassoInputs(X=x, y=y,
+ clusters=list(2:3),
+ nlambda=10))
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=list(1:4,
+ as.integer(NA)),
+ nlambda=10),
+ "!is.na(clusters) are not all TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=list(2:3,
+ c(4, 4, 5)),
+ nlambda=10),
+ "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=good_clusters,
+ nlambda=1),
+ "nlambda >= 2 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=good_clusters,
+ nlambda=x),
+ "length(nlambda) == 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=good_clusters,
+ nlambda="nlambda"),
+ "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(processClusterLassoInputs(X=x, y=y,
+ clusters=good_clusters,
+ nlambda=10.5),
+ "nlambda == round(nlambda) is not TRUE",
+ fixed=TRUE)
+
+})
+## Test passed with 99 successes.
+Tests for checkGetXglmnetInputs():
+testthat::test_that("checkGetXglmnetInputs works", {
set.seed(82612)
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
@@ -490,225 +400,86 @@
process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
nlambda=10)
- res <- getXglmnet(x=process$x, clusters=process$clusters,
+ checkGetXglmnetInputs(x=process$x, clusters=process$clusters,
type="protolasso", prototypes=process$prototypes)
- testthat::expect_true(is.matrix(res))
- testthat::expect_true(is.numeric(res))
- testthat::expect_identical(colnames(res), names(process$clusters))
- testthat::expect_true(nrow(res) == 15)
- # Each column of res should be one of the prototypes. Features 9 - 11 are
- # in clusters by themselves and are therefore their own prototypes.
- testthat::expect_true(ncol(res) == 5)
- for(i in 1:length(good_clusters)){
- proto_i_found <- FALSE
- cluster_i <- good_clusters[[i]]
- for(j in 1:length(cluster_i)){
- proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) <
- 10^(-9))
- }
- testthat::expect_true(proto_i_found)
- }
- testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
-
- res <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- testthat::expect_true(is.matrix(res))
- testthat::expect_true(is.numeric(res))
- testthat::expect_identical(colnames(res), names(process$clusters))
- testthat::expect_true(nrow(res) == 15)
- # Each column of res should be one of the cluster representatives. Features 9
- # - 11 are in clusters by themselves and are therefore their own cluster
- # representatives.
- testthat::expect_true(ncol(res) == 5)
- for(i in 1:length(good_clusters)){
- cluster_i <- good_clusters[[i]]
- clus_rep_i <- rowMeans(x[, cluster_i])
- testthat::expect_true(all(abs(res[, i] - clus_rep_i) <
- 10^(-9)))
- }
- testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
-
- # X as a data.frame
- X_df <- datasets::mtcars
- res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
- clusters=1:3, nlambda=10)
-
- ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso",
- prototypes=res$prototypes)
-
- X_df_model <- stats::model.matrix(~ ., X_df)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- testthat::expect_true(is.matrix(ret_df))
- testthat::expect_true(is.numeric(ret_df))
- testthat::expect_identical(colnames(ret_df), names(res$clusters))
- testthat::expect_true(nrow(ret_df) == nrow(X_df))
- # Each column of ret_df should be one of the prototypes.
- testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1)
+ checkGetXglmnetInputs(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso",
+ prototypes=process$prototypes)
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+ res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
+ clusters=1:3, nlambda=10)
+
+ checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="clusterRepLasso",
+ prototypes=res$prototypes)
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ # Should get an error if clusters are provided since df2 contains factors
+ # with more than two levels
+ testthat::expect_error(processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
+ clusters=1:3, nlambda=10),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+
+ # Should be fine if no clusters are provided
+ res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
+ clusters=list(), nlambda=10)
+
+ checkGetXglmnetInputs(x=res$x, clusters=res$clusters, type="protolasso",
+ prototypes=res$prototypes)
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ ret <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters, nlambda=10)
+
+ checkGetXglmnetInputs(x=ret$x, clusters=ret$clusters, type="clusterRepLasso",
+ prototypes=ret$prototypes)
+
+ # Bad prototype inputs
+ # Error has quotation marks
+ testthat::expect_error(checkGetXglmnetInputs(x=process$x,
+ clusters=process$clusters,
+ type="clsterRepLasso",
+ prototypes=process$prototypes))
+
+ testthat::expect_error(checkGetXglmnetInputs(x=process$x,
+ clusters=process$clusters,
+ type=c("clusterRepLasso",
+ "protolasso"),
+ prototypes=process$prototypes),
+ "length(type) == 1 is not TRUE",
+ fixed=TRUE)
- proto_found <- FALSE
- for(j in 1:3){
- proto_found <- proto_found | all(abs(ret_df[, 1] - X_df_model[, j]) < 10^(-9))
- }
- testthat::expect_true(proto_found)
-
- for(j in 4:ncol(X_df_model)){
- testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9)))
- }
-
- ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso",
- prototypes=res$prototypes)
-
- testthat::expect_true(is.matrix(ret_df))
- testthat::expect_true(is.numeric(ret_df))
- testthat::expect_identical(colnames(ret_df), names(res$clusters))
- testthat::expect_true(nrow(ret_df) == nrow(X_df))
- # Each column of ret_df should be one of the prototypes.
- testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1)
-
- proto_found <- FALSE
- clus_rep <- rowMeans(X_df_model[, 1:3])
- testthat::expect_true(all(abs(ret_df[, 1] - clus_rep) < 10^(-9)))
-
- for(j in 4:ncol(X_df_model)){
- testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9)))
- }
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
- clusters=list(), nlambda=10)
-
- ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso",
- prototypes=res$prototypes)
-
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- testthat::expect_true(is.matrix(ret_df))
- testthat::expect_true(is.numeric(ret_df))
- testthat::expect_identical(colnames(ret_df), names(res$clusters))
- testthat::expect_true(nrow(ret_df) == nrow(X_df))
- # Each column of ret_df should be one of the prototypes.
- testthat::expect_true(ncol(ret_df) == ncol(X_df_model))
-
- for(j in 1:ncol(X_df_model)){
- testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9)))
- }
-
- ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso",
- prototypes=res$prototypes)
-
- testthat::expect_true(is.matrix(ret_df))
- testthat::expect_true(is.numeric(ret_df))
- testthat::expect_identical(colnames(ret_df), names(res$clusters))
- testthat::expect_true(nrow(ret_df) == nrow(X_df))
- # Each column of ret_df should be one of the prototypes.
- testthat::expect_true(ncol(ret_df) == ncol(X_df_model))
-
- for(j in 1:ncol(X_df_model)){
- testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9)))
- }
-
- # X as a matrix with column names (returned X shouldn't have column names)
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters,
- nlambda=10)
-
- res <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
-
- testthat::expect_true(is.matrix(res))
- testthat::expect_true(is.numeric(res))
- testthat::expect_identical(colnames(res), names(process$clusters))
- testthat::expect_true(nrow(res) == 15)
- # Each column of res should be one of the prototypes. Features 9 - 11 are
- # in clusters by themselves and are therefore their own prototypes.
- testthat::expect_true(ncol(res) == 5)
- for(i in 1:length(good_clusters)){
- proto_i_found <- FALSE
- cluster_i <- good_clusters[[i]]
- for(j in 1:length(cluster_i)){
- proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) <
- 10^(-9))
- }
- testthat::expect_true(proto_i_found)
- }
- testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
-
- res <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- testthat::expect_true(is.matrix(res))
- testthat::expect_true(is.numeric(res))
- testthat::expect_identical(colnames(res), names(process$clusters))
- testthat::expect_true(nrow(res) == 15)
- # Each column of res should be one of the cluster representatives. Features 9
- # - 11 are in clusters by themselves and are therefore their own cluster
- # representatives.
- testthat::expect_true(ncol(res) == 5)
- for(i in 1:length(good_clusters)){
- cluster_i <- good_clusters[[i]]
- clus_rep_i <- rowMeans(x[, cluster_i])
- testthat::expect_true(all(abs(res[, i] - clus_rep_i) <
- 10^(-9)))
- }
- testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
- testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
-
- # Bad prototype inputs
- # Error has quotation marks
- testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
- type="clsterRepLasso",
- prototypes=process$prototypes))
-
- testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
- type=c("clusterRepLasso", "protolasso"),
- prototypes=process$prototypes),
- "length(type) == 1 is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
- type=2, prototypes=process$prototypes),
- "is.character(type) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
- type=as.character(NA),
- prototypes=process$prototypes),
- "!is.na(type) is not TRUE",
- fixed=TRUE)
-
- # do.call(cbind) preserves integer storage of an integer x (#58)
- x_int <- matrix(1:12, nrow = 4, ncol = 3)
- int_clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L)
- res_int <- getXglmnet(x_int, int_clusters, type = "protolasso",
- prototypes = c(1L, 2L, 3L))
- testthat::expect_true(is.integer(res_int))
-
-})
-## Test passed with 117 successes.
-Tests for getSelectedSets():
-testthat::test_that("getSelectedSets works", {
+ testthat::expect_error(checkGetXglmnetInputs(x=process$x,
+ clusters=process$clusters,
+ type=2,
+ prototypes=process$prototypes),
+ "is.character(type) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGetXglmnetInputs(x=process$x,
+ clusters=process$clusters,
+ type=as.character(NA),
+ prototypes=process$prototypes),
+ "!is.na(type) is not TRUE",
+ fixed=TRUE)
+
+})
+## Test passed with 5 successes.
+Tests for getXglmnet():
+testthat::test_that("getXglmnet works", {
set.seed(82612)
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
@@ -717,319 +488,228 @@
good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
- nlambda=100)
+ nlambda=10)
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
+ res <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
- fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[5]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:11))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
- # Try again with cluster representative lasso
-
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
+ testthat::expect_true(is.matrix(res))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_identical(colnames(res), names(process$clusters))
+ testthat::expect_true(nrow(res) == 15)
+ # Each column of res should be one of the prototypes. Features 9 - 11 are
+ # in clusters by themselves and are therefore their own prototypes.
+ testthat::expect_true(ncol(res) == 5)
+ for(i in 1:length(good_clusters)){
+ proto_i_found <- FALSE
+ cluster_i <- good_clusters[[i]]
+ for(j in 1:length(cluster_i)){
+ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) <
+ 10^(-9))
+ }
+ testthat::expect_true(proto_i_found)
+ }
+ testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
+
+ res <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ testthat::expect_true(is.matrix(res))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_identical(colnames(res), names(process$clusters))
+ testthat::expect_true(nrow(res) == 15)
+ # Each column of res should be one of the cluster representatives. Features 9
+ # - 11 are in clusters by themselves and are therefore their own cluster
+ # representatives.
+ testthat::expect_true(ncol(res) == 5)
+ for(i in 1:length(good_clusters)){
+ cluster_i <- good_clusters[[i]]
+ clus_rep_i <- rowMeans(x[, cluster_i])
+ testthat::expect_true(all(abs(res[, i] - clus_rep_i) <
+ 10^(-9)))
+ }
+ testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
- fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[5]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:11))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
-
-
-
-
- # X as a data.frame
- X_df <- datasets::mtcars
+ # X as a data.frame
+ X_df <- datasets::mtcars
+ res <- processClusterLassoInputs(X=X_df, y=stats::rnorm(nrow(X_df)),
+ clusters=1:3, nlambda=10)
+
+ ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso",
+ prototypes=res$prototypes)
+
+ X_df_model <- stats::model.matrix(~ ., X_df)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ testthat::expect_true(is.matrix(ret_df))
+ testthat::expect_true(is.numeric(ret_df))
+ testthat::expect_identical(colnames(ret_df), names(res$clusters))
+ testthat::expect_true(nrow(ret_df) == nrow(X_df))
+ # Each column of ret_df should be one of the prototypes.
+ testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1)
+
+ proto_found <- FALSE
+ for(j in 1:3){
+ proto_found <- proto_found | all(abs(ret_df[, 1] - X_df_model[, j]) < 10^(-9))
+ }
+ testthat::expect_true(proto_found)
+
+ for(j in 4:ncol(X_df_model)){
+ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9)))
+ }
+
+ ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso",
+ prototypes=res$prototypes)
+
+ testthat::expect_true(is.matrix(ret_df))
+ testthat::expect_true(is.numeric(ret_df))
+ testthat::expect_identical(colnames(ret_df), names(res$clusters))
+ testthat::expect_true(nrow(ret_df) == nrow(X_df))
+ # Each column of ret_df should be one of the prototypes.
+ testthat::expect_true(ncol(ret_df) == ncol(X_df_model) - 3 + 1)
+
+ proto_found <- FALSE
+ clus_rep <- rowMeans(X_df_model[, 1:3])
+ testthat::expect_true(all(abs(ret_df[, 1] - clus_rep) < 10^(-9)))
- X_df_model <- stats::model.matrix(~ ., X_df)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)),
- clusters=1:3, nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
+ for(j in 4:ncol(X_df_model)){
+ testthat::expect_true(all(abs(ret_df[, j - 2] - X_df_model[, j]) < 10^(-9)))
+ }
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ res <- processClusterLassoInputs(X=df2, y=stats::rnorm(nrow(df2)),
+ clusters=list(), nlambda=10)
+
+ ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="protolasso",
+ prototypes=res$prototypes)
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ testthat::expect_true(is.matrix(ret_df))
+ testthat::expect_true(is.numeric(ret_df))
+ testthat::expect_identical(colnames(ret_df), names(res$clusters))
+ testthat::expect_true(nrow(ret_df) == nrow(X_df))
+ # Each column of ret_df should be one of the prototypes.
+ testthat::expect_true(ncol(ret_df) == ncol(X_df_model))
+
+ for(j in 1:ncol(X_df_model)){
+ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9)))
+ }
+
+ ret_df <- getXglmnet(x=res$x, clusters=res$clusters, type="clusterRepLasso",
+ prototypes=res$prototypes)
+
+ testthat::expect_true(is.matrix(ret_df))
+ testthat::expect_true(is.numeric(ret_df))
+ testthat::expect_identical(colnames(ret_df), names(res$clusters))
+ testthat::expect_true(nrow(ret_df) == nrow(X_df))
+ # Each column of ret_df should be one of the prototypes.
+ testthat::expect_true(ncol(ret_df) == ncol(X_df_model))
+
+ for(j in 1:ncol(X_df_model)){
+ testthat::expect_true(all(abs(ret_df[, j] - X_df_model[, j]) < 10^(-9)))
+ }
+
+ # X as a matrix with column names (returned X shouldn't have column names)
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ process <- processClusterLassoInputs(X=x2, y=y, clusters=good_clusters,
+ nlambda=10)
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- # Should throw an error if we assign clusters because df2 contains factors
- # with more than two levels
- testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
- clusters=1:3, nlambda=100),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
-
- # Should be fine if no clusters are provided
- process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
- clusters=list(), nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
-
-
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- # Should throw an error if we assign clusters because df2 contains factors
- # with more than two levels
- testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
- clusters=1:3, nlambda=100),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+ res <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ testthat::expect_true(is.matrix(res))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_identical(colnames(res), names(process$clusters))
+ testthat::expect_true(nrow(res) == 15)
+ # Each column of res should be one of the prototypes. Features 9 - 11 are
+ # in clusters by themselves and are therefore their own prototypes.
+ testthat::expect_true(ncol(res) == 5)
+ for(i in 1:length(good_clusters)){
+ proto_i_found <- FALSE
+ cluster_i <- good_clusters[[i]]
+ for(j in 1:length(cluster_i)){
+ proto_i_found <- proto_i_found | all(abs(res[, i] - x[, cluster_i[j]]) <
+ 10^(-9))
+ }
+ testthat::expect_true(proto_i_found)
+ }
+ testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
+
+ res <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ testthat::expect_true(is.matrix(res))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_identical(colnames(res), names(process$clusters))
+ testthat::expect_true(nrow(res) == 15)
+ # Each column of res should be one of the cluster representatives. Features 9
+ # - 11 are in clusters by themselves and are therefore their own cluster
+ # representatives.
+ testthat::expect_true(ncol(res) == 5)
+ for(i in 1:length(good_clusters)){
+ cluster_i <- good_clusters[[i]]
+ clus_rep_i <- rowMeans(x[, cluster_i])
+ testthat::expect_true(all(abs(res[, i] - clus_rep_i) <
+ 10^(-9)))
+ }
+ testthat::expect_true(all(abs(res[, 3] - x[, 9]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 4] - x[, 10]) < 10^(-9)))
+ testthat::expect_true(all(abs(res[, 5] - x[, 11]) < 10^(-9)))
+
+ # Bad prototype inputs
+ # Error has quotation marks
+ testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
+ type="clsterRepLasso",
+ prototypes=process$prototypes))
+
+ testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
+ type=c("clusterRepLasso", "protolasso"),
+ prototypes=process$prototypes),
+ "length(type) == 1 is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
+ type=2, prototypes=process$prototypes),
+ "is.character(type) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getXglmnet(x=process$x, clusters=process$clusters,
+ type=as.character(NA),
+ prototypes=process$prototypes),
+ "!is.na(type) is not TRUE",
+ fixed=TRUE)
+
+ # do.call(cbind) preserves integer storage of an integer x (#58)
+ x_int <- matrix(1:12, nrow = 4, ncol = 3)
+ int_clusters <- list(c1 = 1L, c2 = 2L, c3 = 3L)
+ res_int <- getXglmnet(x_int, int_clusters, type = "protolasso",
+ prototypes = c(1L, 2L, 3L))
+ testthat::expect_true(is.integer(res_int))
- # Should be fine if no clusters are provided
- process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
- clusters=list(), nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
-
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- process <- processClusterLassoInputs(X=x2, y=y,
- clusters=good_clusters, nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
- # Pick an arbitrary lasso set
- lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
-
- res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
- process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_set",
- "selected_clusts_list"))
-
- # selected_set
- testthat::expect_true(is.integer(res$selected_set))
- testthat::expect_true(all(!is.na(res$selected_set)))
- testthat::expect_true(all(res$selected_set %in% process$prototypes))
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- testthat::expect_equal(length(res$selected_set),
- length(res$selected_clusts_list))
- sel_feats <- unlist(res$selected_clusts_list)
- testthat::expect_true(all(sel_feats %in% 1:11))
- n_clusts <- length(res$selected_clusts_list)
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
-
-})
-## Test passed with 80 successes.
-Tests for getClusterSelsFromGlmnet():
-
+## Test passed with 117 successes.
+Tests for getSelectedSets():
+testthat::test_that("getSelectedSets works", {
+ set.seed(82612)
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
y <- stats::rnorm(15)
@@ -1043,392 +723,712 @@
type="protolasso", prototypes=process$prototypes)
fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
- # Deliberately the raw predict.glmnet idiom rather than clusterLassoCore()'s
- # normalisation (#190). These fixtures exercise the CONSUMER against the
- # installed glmnet, bypassing the boundary on purpose, which is what makes
- # them complementary to the mocked shape pins further below; copying the
- # normalisation in here would defeat that.
- #
- # The two assertions beside each such fixture -- here and in the
- # "getSelectedSets works" block above -- are the canary for that choice. On a
- # glmnet that returned a data.frame, the fixtures in THIS block would stop at
- # the consumer's new guard, but that block's would not: it indexes a single
- # element out and calls getSelectedSets(), which this PR does not guard, and
- # a data.frame's [[k]] is column k -- a well-formed integer vector whose
- # assertions pass silently. The canary makes both blocks fail the same,
- # legible way instead.
- #
- # BOTH assertions are needed, for the same reason the consumer needs two
- # guards: a data.frame IS a list, so expect_true(is.list(...)) alone passes
- # on the very container this is watching for. The pair mirrors
- # getClusterSelsFromGlmnet()'s own stopifnot() pair exactly.
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
-
- res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
- process$prototypes, process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[5]]
+
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
+
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+ # Try again with cluster representative lasso
+
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[5]]
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i,
- process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # Try again with cluster representative lasso
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
-
- res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
- process$prototypes, process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i,
- process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
-
-
-
-
- # X as a data.frame
- X_df <- datasets::mtcars
-
- X_df_model <- stats::model.matrix(~ ., X_df)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)),
- clusters=1:3, nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
+
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+
+
+
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+
+ X_df_model <- stats::model.matrix(~ ., X_df)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)),
+ clusters=1:3, nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
+
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
+
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ # Should throw an error if we assign clusters because df2 contains factors
+ # with more than two levels
+ testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
+ clusters=1:3, nlambda=100),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+
+ # Should be fine if no clusters are provided
+ process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
+ clusters=list(), nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
- fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
-
- res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
- process$prototypes, process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
+
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i,
- process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ # Should throw an error if we assign clusters because df2 contains factors
+ # with more than two levels
+ testthat::expect_error(processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
+ clusters=1:3, nlambda=100),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+
+ # Should be fine if no clusters are provided
+ process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
+ clusters=list(), nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
+
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
- clusters=list(), nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="clusterRepLasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
- nlambda=100)
-
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
-
- res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
- process$prototypes, process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list"))
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i,
- process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
-
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- process <- processClusterLassoInputs(X=x2, y=y,
- clusters=good_clusters, nlambda=100)
-
- X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
- type="protolasso", prototypes=process$prototypes)
-
- fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian",
- nlambda=100)
- lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
- testthat::expect_true(is.list(lasso_sets))
- testthat::expect_false(is.data.frame(lasso_sets))
-
- res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
- process$prototypes, process$var_names)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(process$clusters)){
- clust_i_found <- clust_i_found | identical(clust_i,
- process$clusters[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # An all-empty lasso path (max_length == 0) must return an empty selection,
- # not crash with "model_size > 0 is not TRUE" (#157).
- out_empty <- getClusterSelsFromGlmnet(list(integer(0)), clusters = list(1L),
- prototypes = 1L, feat_names = NA)
- testthat::expect_length(out_empty$selected_sets, 0)
- testthat::expect_length(out_empty$selected_clusts_list, 0)
-})
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ process <- processClusterLassoInputs(X=x2, y=y,
+ clusters=good_clusters, nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+ # Pick an arbitrary lasso set
+ lasso_set <- lasso_sets[[min(length(lasso_sets), 3)]]
+
+ res <- getSelectedSets(lasso_set, process$clusters, process$prototypes,
+ process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_set",
+ "selected_clusts_list"))
+
+ # selected_set
+ testthat::expect_true(is.integer(res$selected_set))
+ testthat::expect_true(all(!is.na(res$selected_set)))
+ testthat::expect_true(all(res$selected_set %in% process$prototypes))
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ testthat::expect_equal(length(res$selected_set),
+ length(res$selected_clusts_list))
+ sel_feats <- unlist(res$selected_clusts_list)
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ n_clusts <- length(res$selected_clusts_list)
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i, process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+
+})## Test passed with 80 successes.Tests for getClusterSelsFromGlmnet():
testthat::test_that("getClusterSelsFromGlmnet works", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
+ nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
+ # Deliberately the raw predict.glmnet idiom rather than clusterLassoCore()'s
+ # normalisation (#190). These fixtures exercise the CONSUMER against the
+ # installed glmnet, bypassing the boundary on purpose, which is what makes
+ # them complementary to the mocked shape pins further below; copying the
+ # normalisation in here would defeat that.
+ #
+ # The two assertions beside each such fixture -- here and in the
+ # "getSelectedSets works" block above -- are the canary for that choice. On a
+ # glmnet that returned a data.frame, the fixtures in THIS block would stop at
+ # the consumer's new guard, but that block's would not: it indexes a single
+ # element out and calls getSelectedSets(), which this PR does not guard, and
+ # a data.frame's [[k]] is column k -- a well-formed integer vector whose
+ # assertions pass silently. The canary makes both blocks fail the same,
+ # legible way instead.
+ #
+ # BOTH assertions are needed, for the same reason the consumer needs two
+ # guards: a data.frame IS a list, so expect_true(is.list(...)) alone passes
+ # on the very container this is watching for. The pair mirrors
+ # getClusterSelsFromGlmnet()'s own stopifnot() pair exactly.
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+
+ res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
+ process$prototypes, process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # Try again with cluster representative lasso
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian", nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+
+ res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
+ process$prototypes, process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+
+
+
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+
+ X_df_model <- stats::model.matrix(~ ., X_df)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ process <- processClusterLassoInputs(X=X_df, y=rnorm(nrow(X_df)),
+ clusters=1:3, nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(X_df)), family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+
+ res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
+ process$prototypes, process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ process <- processClusterLassoInputs(X=df2, y=rnorm(nrow(df2)),
+ clusters=list(), nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="clusterRepLasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=rnorm(nrow(df2)), family="gaussian",
+ nlambda=100)
+
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+
+ res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
+ process$prototypes, process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ process <- processClusterLassoInputs(X=x2, y=y,
+ clusters=good_clusters, nlambda=100)
+
+ X_glmnet <- getXglmnet(x=process$x, clusters=process$clusters,
+ type="protolasso", prototypes=process$prototypes)
+
+ fit <- glmnet::glmnet(x=X_glmnet, y=y, family="gaussian",
+ nlambda=100)
+ lasso_sets <- unique(glmnet::predict.glmnet(fit, type="nonzero"))
+ testthat::expect_true(is.list(lasso_sets))
+ testthat::expect_false(is.data.frame(lasso_sets))
+
+ res <- getClusterSelsFromGlmnet(lasso_sets, process$clusters,
+ process$prototypes, process$var_names)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% process$prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(process$clusters)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ process$clusters[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # An all-empty lasso path (max_length == 0) must return an empty selection,
+ # not crash with "model_size > 0 is not TRUE" (#157).
+ out_empty <- getClusterSelsFromGlmnet(list(integer(0)), clusters = list(1L),
+ prototypes = 1L, feat_names = NA)
+ testthat::expect_length(out_empty$selected_sets, 0)
+ testthat::expect_length(out_empty$selected_clusts_list, 0)
+})## Test passed with 594 successes.predict.glmnet(type = "nonzero") does not return a stable container across glmnet
versions here either, and unlike cssLasso() this path must preserve one slot per
@@ -1460,230 +1460,230 @@
data.frame whose ncol and nrow
both differ from the penalty count – rather than structural, so it is worth one assertion.
-testthat::test_that("clusterLassoCore normalises a single-column data.frame (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # glmnet 4.x's shape when every penalty selected exactly ONE feature: apply()
- # collapses to a vector, so data.frame() gives a single column with one ROW
- # per penalty and the column<->penalty convention inverts. Read as a list
- # this is one model of size n_pen; read correctly it is n_pen models of size
- # 1. The values must cycle through more than one index, or the two readings
- # coincide and this block cannot go red.
- #
- # The cycle needs n_pen >= 3, so assert it rather than documenting it: at
- # n_pen == 1 the fixture is a 1 x 1 data.frame, both readings agree, and this
- # block would pass pre-fix -- a green red-green test, which is worse than no
- # test at all.
- testthat::local_mocked_bindings(
- predict.glmnet = function(object, ...){
- testthat::expect_gte(ncol(object$beta), 3L)
- data.frame(which=rep_len(c(1L, 2L, 3L), ncol(object$beta)))
- }, .package="glmnet")
-
- res <- protolasso(x, y, good_clusters, nlambda=100)
-
- # Pre-fix, unique() dedupes the data.frame's ROWS and lengths() then counts
- # rows per column, so this fixture is read as max_length = 3: the block sees
- # selected_sets of length 3, holding a fabricated size-3 model c(1L, 7L, 9L)
- # that glmnet never selected, and drops the genuine size-1 one. Both
- # assertions below move.
- testthat::expect_length(res$selected_sets, 1)
- testthat::expect_identical(res$selected_sets[[1]], 1L)
-})
-
-testthat::test_that("clusterLassoCore normalises a multi-column data.frame (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # glmnet 4.x's other data.frame layout: every penalty selected the same
- # NUMBER k >= 2 of features -- the sets may differ, {1,2} and {2,3} qualify
- # -- so apply() returns a k x n_pen matrix and data.frame() lays out one
- # COLUMN per penalty. This one degenerates to the right answer
- # pre-fix -- each column is strictly increasing down the rows, so no two rows
- # can be equal and unique() is a no-op on it -- which makes this a pin rather
- # than a red-green test. It holds the column-major branch of the
- # normalisation against a later refactor, and it goes red if the two branches
- # are transposed or the reshaping is deleted.
- #
- # Driven through clusterRepLasso() so the shared clusterLassoCore() body is
- # covered from both exported entry points.
- testthat::local_mocked_bindings(
- predict.glmnet = function(object, ...){
- n_pen <- ncol(object$beta)
- as.data.frame(matrix(rep_len(c(1L, 2L, 1L, 3L), 2L*n_pen), nrow=2L,
- ncol=n_pen))
- }, .package="glmnet")
-
- res <- clusterRepLasso(x, y, good_clusters, nlambda=100)
-
- # Design indices 1 and 2 are red_cluster and green_cluster, whose prototypes
- # are features 1 and 7; getSelectedSets() maps the fixture's indices back
- # through prototypes, so these are not the fixture's own integers.
- testthat::expect_length(res$selected_sets, 2)
- testthat::expect_null(res$selected_sets[[1]])
- testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L))
-})
-
-testthat::test_that("clusterLassoCore leaves the list shape alone (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # The branch glmnet 5.0 always takes, and the one 4.x takes here today.
- # Mixed sizes and a NULL slot, so the fixture is not degenerate.
- #
- # This is a pin, not a red-green test, and it is deliberately kept despite
- # being green pre-fix: measured green under deleting the reshaping and under
- # replacing it with a bare as.list(), because both leave a list untouched.
- # What it does catch is applying the reshaping UNCONDITIONALLY -- dropping
- # the is.data.frame() test on the grounds that "the reshape is harmless on a
- # list" is the likeliest future edit to that block -- under which it errors
- # with "'list' object cannot be coerced to type 'integer'". Apart from the
- # entry-count block below, which trips a different assertion incidentally,
- # this block catches that. It is not the only one -- an unconditional
- # reshape reaches as.integer() on a list from every caller, so the
- # end-to-end protolasso/clusterRepLasso blocks error too -- but it is the
- # only one of the mocked shape pins that does.
- testthat::local_mocked_bindings(
- predict.glmnet = function(object, ...){
- testthat::expect_gte(ncol(object$beta), 3L)
- rep_len(list(NULL, 1L, c(1L, 2L)), ncol(object$beta))
- }, .package="glmnet")
-
- res <- protolasso(x, y, good_clusters, nlambda=100)
-
- testthat::expect_length(res$selected_sets, 2)
- testthat::expect_identical(res$selected_sets[[1]], 1L)
- testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L))
-})
-
-testthat::test_that("getClusterSelsFromGlmnet rejects a data.frame (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
- nlambda=100)
-
- # The message pin separates the NEW guard from the downstream
- # all(lasso_set <= length(clusters)) check in getSelectedSets(), which fires
- # only when the fixture's indices exceed length(clusters). Measured on
- # 2f66a14 with this five-cluster fixture: the call returns cleanly
- # (selected_sets of length 2), so a bare expect_error() is red-green here as
- # well -- but it would go green again on any later edit that made this call
- # error for some unrelated reason, which is why the pin stays.
- #
- # fixed=TRUE is mandatory: the message contains "!", "(" and ".", so it does
- # not match itself as a regex.
- testthat::expect_error(
- getClusterSelsFromGlmnet(data.frame(which=c(1L, 2L)), process$clusters,
- process$prototypes, process$var_names),
- "!is.data.frame(lasso_sets) is not TRUE", fixed=TRUE)
-})
-
-testthat::test_that("clusterLassoCore requires one entry per penalty (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # The entry-count assertion is a new bound on the default code path: before
- # #190 clusterLassoCore() accepted whatever predict.glmnet handed it,
- # afterwards it refuses anything whose entry count differs from
- # ncol(fit$beta). Nothing else observes it, so without this block a later
- # weakening of it would go unnoticed. On glmnet 4.1.9 the bound excludes
- # nothing (400/400 agreement over random fits); CI's R-CMD-check matrix,
- # which installs glmnet 5.0, is its cross-version test.
- testthat::local_mocked_bindings(
- predict.glmnet = function(object, ...){
- rep_len(list(1L), ncol(object$beta) + 1L)
- }, .package="glmnet")
-
- testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100),
- "identical(length(nonzero), n_pen) is not TRUE",
- fixed=TRUE)
-})
-
-testthat::test_that("getClusterSelsFromGlmnet rejects a non-list (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
- nlambda=100)
-
- # The data.frame block above can never reach the is.list() guard, because a
- # data.frame IS a list and its fixture always falls through to the second
- # guard; this block is the only thing that exercises the first. Measured on
- # 2f66a14: this call returns cleanly (selected_sets of length 1), so the red
- # side is a clean "no error was thrown".
- testthat::expect_error(
- getClusterSelsFromGlmnet(1:3, process$clusters, process$prototypes,
- process$var_names),
- "is.list(lasso_sets) is not TRUE", fixed=TRUE)
-})
-
-testthat::test_that("clusterLassoCore reads a square data.frame column-major (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # The one shape on which BOTH branch predicates are true: k == n_pen, so
- # ncol(nonzero_mat) == n_pen and nrow(nonzero_mat) == n_pen alike. The
- # normalisation resolves it by testing ncol first, which is correct --
- # apply() simplifies to a matrix only when it has one column per penalty --
- # but nothing else in this file pins that ORDER, because no other fixture is
- # square (the single-column one is n_pen x 1, the multi-column one 2 x n_pen).
- #
- # Swapping the predicate and the two readings together is wrong on exactly
- # this shape and correct everywhere else, so without this block that refactor
- # passes the whole suite while reintroducing #190's failure mode: confidently
- # wrong model sizes. Read row-major, slot 1 is ROW 1 -- c(1L, 1L, 1L) --
- # which getSelectedSets() rejects for having duplicates.
- #
- # nlambda is honoured exactly at small values (measured: 2 -> 2, 3 -> 3), so
- # a square fixture is directly constructible; assert it rather than trusting
- # it, since a shortened path would make this block vacuous.
- testthat::local_mocked_bindings(
- predict.glmnet = function(object, ...){
- n_pen <- ncol(object$beta)
- testthat::expect_identical(n_pen, 3L)
- as.data.frame(matrix(c(1L, 2L, 3L, 1L, 2L, 4L, 1L, 3L, 4L), nrow=3L,
- ncol=3L))
- }, .package="glmnet")
-
- res <- protolasso(x, y, good_clusters, nlambda=3)
-
- # Prototypes are c(1, 7, 9, 10, 11), so the fixture's first column c(1, 2, 3)
- # maps to features 1, 7 and 9.
- testthat::expect_length(res$selected_sets, 3)
- testthat::expect_null(res$selected_sets[[1]])
- testthat::expect_null(res$selected_sets[[2]])
- testthat::expect_identical(res$selected_sets[[3]], c(1L, 7L, 9L))
-})testthat::test_that("clusterLassoCore normalises a single-column data.frame (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # glmnet 4.x's shape when every penalty selected exactly ONE feature: apply()
+ # collapses to a vector, so data.frame() gives a single column with one ROW
+ # per penalty and the column<->penalty convention inverts. Read as a list
+ # this is one model of size n_pen; read correctly it is n_pen models of size
+ # 1. The values must cycle through more than one index, or the two readings
+ # coincide and this block cannot go red.
+ #
+ # The cycle needs n_pen >= 3, so assert it rather than documenting it: at
+ # n_pen == 1 the fixture is a 1 x 1 data.frame, both readings agree, and this
+ # block would pass pre-fix -- a green red-green test, which is worse than no
+ # test at all.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(object, ...){
+ testthat::expect_gte(ncol(object$beta), 3L)
+ data.frame(which=rep_len(c(1L, 2L, 3L), ncol(object$beta)))
+ }, .package="glmnet")
+
+ res <- protolasso(x, y, good_clusters, nlambda=100)
+
+ # Pre-fix, unique() dedupes the data.frame's ROWS and lengths() then counts
+ # rows per column, so this fixture is read as max_length = 3: the block sees
+ # selected_sets of length 3, holding a fabricated size-3 model c(1L, 7L, 9L)
+ # that glmnet never selected, and drops the genuine size-1 one. Both
+ # assertions below move.
+ testthat::expect_length(res$selected_sets, 1)
+ testthat::expect_identical(res$selected_sets[[1]], 1L)
+})
+
+testthat::test_that("clusterLassoCore normalises a multi-column data.frame (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # glmnet 4.x's other data.frame layout: every penalty selected the same
+ # NUMBER k >= 2 of features -- the sets may differ, {1,2} and {2,3} qualify
+ # -- so apply() returns a k x n_pen matrix and data.frame() lays out one
+ # COLUMN per penalty. This one degenerates to the right answer
+ # pre-fix -- each column is strictly increasing down the rows, so no two rows
+ # can be equal and unique() is a no-op on it -- which makes this a pin rather
+ # than a red-green test. It holds the column-major branch of the
+ # normalisation against a later refactor, and it goes red if the two branches
+ # are transposed or the reshaping is deleted.
+ #
+ # Driven through clusterRepLasso() so the shared clusterLassoCore() body is
+ # covered from both exported entry points.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(object, ...){
+ n_pen <- ncol(object$beta)
+ as.data.frame(matrix(rep_len(c(1L, 2L, 1L, 3L), 2L*n_pen), nrow=2L,
+ ncol=n_pen))
+ }, .package="glmnet")
+
+ res <- clusterRepLasso(x, y, good_clusters, nlambda=100)
+
+ # Design indices 1 and 2 are red_cluster and green_cluster, whose prototypes
+ # are features 1 and 7; getSelectedSets() maps the fixture's indices back
+ # through prototypes, so these are not the fixture's own integers.
+ testthat::expect_length(res$selected_sets, 2)
+ testthat::expect_null(res$selected_sets[[1]])
+ testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L))
+})
+
+testthat::test_that("clusterLassoCore leaves the list shape alone (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # The branch glmnet 5.0 always takes, and the one 4.x takes here today.
+ # Mixed sizes and a NULL slot, so the fixture is not degenerate.
+ #
+ # This is a pin, not a red-green test, and it is deliberately kept despite
+ # being green pre-fix: measured green under deleting the reshaping and under
+ # replacing it with a bare as.list(), because both leave a list untouched.
+ # What it does catch is applying the reshaping UNCONDITIONALLY -- dropping
+ # the is.data.frame() test on the grounds that "the reshape is harmless on a
+ # list" is the likeliest future edit to that block -- under which it errors
+ # with "'list' object cannot be coerced to type 'integer'". Apart from the
+ # entry-count block below, which trips a different assertion incidentally,
+ # this block catches that. It is not the only one -- an unconditional
+ # reshape reaches as.integer() on a list from every caller, so the
+ # end-to-end protolasso/clusterRepLasso blocks error too -- but it is the
+ # only one of the mocked shape pins that does.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(object, ...){
+ testthat::expect_gte(ncol(object$beta), 3L)
+ rep_len(list(NULL, 1L, c(1L, 2L)), ncol(object$beta))
+ }, .package="glmnet")
+
+ res <- protolasso(x, y, good_clusters, nlambda=100)
+
+ testthat::expect_length(res$selected_sets, 2)
+ testthat::expect_identical(res$selected_sets[[1]], 1L)
+ testthat::expect_identical(res$selected_sets[[2]], c(1L, 7L))
+})
+
+testthat::test_that("getClusterSelsFromGlmnet rejects a data.frame (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
+ nlambda=100)
+
+ # The message pin separates the NEW guard from the downstream
+ # all(lasso_set <= length(clusters)) check in getSelectedSets(), which fires
+ # only when the fixture's indices exceed length(clusters). Measured on
+ # 2f66a14 with this five-cluster fixture: the call returns cleanly
+ # (selected_sets of length 2), so a bare expect_error() is red-green here as
+ # well -- but it would go green again on any later edit that made this call
+ # error for some unrelated reason, which is why the pin stays.
+ #
+ # fixed=TRUE is mandatory: the message contains "!", "(" and ".", so it does
+ # not match itself as a regex.
+ testthat::expect_error(
+ getClusterSelsFromGlmnet(data.frame(which=c(1L, 2L)), process$clusters,
+ process$prototypes, process$var_names),
+ "!is.data.frame(lasso_sets) is not TRUE", fixed=TRUE)
+})
+
+testthat::test_that("clusterLassoCore requires one entry per penalty (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # The entry-count assertion is a new bound on the default code path: before
+ # #190 clusterLassoCore() accepted whatever predict.glmnet handed it,
+ # afterwards it refuses anything whose entry count differs from
+ # ncol(fit$beta). Nothing else observes it, so without this block a later
+ # weakening of it would go unnoticed. On glmnet 4.1.9 the bound excludes
+ # nothing (400/400 agreement over random fits); CI's R-CMD-check matrix,
+ # which installs glmnet 5.0, is its cross-version test.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(object, ...){
+ rep_len(list(1L), ncol(object$beta) + 1L)
+ }, .package="glmnet")
+
+ testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100),
+ "identical(length(nonzero), n_pen) is not TRUE",
+ fixed=TRUE)
+})
+
+testthat::test_that("getClusterSelsFromGlmnet rejects a non-list (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ process <- processClusterLassoInputs(X=x, y=y, clusters=good_clusters,
+ nlambda=100)
+
+ # The data.frame block above can never reach the is.list() guard, because a
+ # data.frame IS a list and its fixture always falls through to the second
+ # guard; this block is the only thing that exercises the first. Measured on
+ # 2f66a14: this call returns cleanly (selected_sets of length 1), so the red
+ # side is a clean "no error was thrown".
+ testthat::expect_error(
+ getClusterSelsFromGlmnet(1:3, process$clusters, process$prototypes,
+ process$var_names),
+ "is.list(lasso_sets) is not TRUE", fixed=TRUE)
+})
+
+testthat::test_that("clusterLassoCore reads a square data.frame column-major (#190)", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # The one shape on which BOTH branch predicates are true: k == n_pen, so
+ # ncol(nonzero_mat) == n_pen and nrow(nonzero_mat) == n_pen alike. The
+ # normalisation resolves it by testing ncol first, which is correct --
+ # apply() simplifies to a matrix only when it has one column per penalty --
+ # but nothing else in this file pins that ORDER, because no other fixture is
+ # square (the single-column one is n_pen x 1, the multi-column one 2 x n_pen).
+ #
+ # Swapping the predicate and the two readings together is wrong on exactly
+ # this shape and correct everywhere else, so without this block that refactor
+ # passes the whole suite while reintroducing #190's failure mode: confidently
+ # wrong model sizes. Read row-major, slot 1 is ROW 1 -- c(1L, 1L, 1L) --
+ # which getSelectedSets() rejects for having duplicates.
+ #
+ # nlambda is honoured exactly at small values (measured: 2 -> 2, 3 -> 3), so
+ # a square fixture is directly constructible; assert it rather than trusting
+ # it, since a shortened path would make this block vacuous.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(object, ...){
+ n_pen <- ncol(object$beta)
+ testthat::expect_identical(n_pen, 3L)
+ as.data.frame(matrix(c(1L, 2L, 3L, 1L, 2L, 4L, 1L, 3L, 4L), nrow=3L,
+ ncol=3L))
+ }, .package="glmnet")
+
+ res <- protolasso(x, y, good_clusters, nlambda=3)
+
+ # Prototypes are c(1, 7, 9, 10, 11), so the fixture's first column c(1, 2, 3)
+ # maps to features 1, 7 and 9.
+ testthat::expect_length(res$selected_sets, 3)
+ testthat::expect_null(res$selected_sets[[1]])
+ testthat::expect_null(res$selected_sets[[2]])
+ testthat::expect_identical(res$selected_sets[[3]], c(1L, 7L, 9L))
+})## Test passed with 3 successes.## Test passed with 3 successes.## Test passed with 4 successes.is.list() / !is.data.frame() pair it guards a reachable-in-principle shape – a
data.frame whose ncol and nrow both differ from the penalty count – so it costs one
assertion rather than being unpinnable.
-testthat::test_that("clusterLassoCore rejects a data.frame of neither orientation (#190)", {
- set.seed(61282)
-
- x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
- y <- stats::rnorm(15)
-
- good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # Neither ncol nor nrow matches n_pen (66 on this design at nlambda = 100),
- # so the reshaping cannot tell which orientation it is looking at and stops
- # instead of guessing. No glmnet in play emits this, which is why the guard
- # is otherwise unobserved.
- testthat::local_mocked_bindings(
- predict.glmnet = function(...) data.frame(a=1:2, b=3:4),
- .package="glmnet")
-
- testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100),
- "nrow(nonzero_mat) == n_pen is not TRUE", fixed=TRUE)
-})## Test passed with 1 success.Finally, tests for protolasso():
testthat::test_that("protolasso works", {
+testthat::test_that("clusterLassoCore rejects a data.frame of neither orientation (#190)", {
set.seed(61282)
-
+
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
y <- stats::rnorm(15)
-
+
good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
-
- # Get properly formatted clusters and prototypes for testing
- format_clust_res <- formatClusters(clusters=good_clusters, p=11,
- clust_names=names(good_clusters),
- get_prototypes=TRUE, x=x, y=y)
-
- prototypes <- format_clust_res$prototypes
- clus_formatted <- format_clust_res$clusters
-
- res <- protolasso(x, y, good_clusters, nlambda=60)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- testthat::expect_true(is.null(names(res$selected_sets[[i]])))
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
- testthat::expect_true(ncol(res$beta) <= 60)
-
-
- # X as a data.frame
- X_df <- datasets::mtcars
-
- X_df_model <- stats::model.matrix(~ ., X_df)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- y_df <- rnorm(nrow(X_df))
-
- # Get properly formatted clusters and prototypes for testing
- format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model),
- get_prototypes=TRUE, x=X_df_model, y=y_df)
-
- prototypes <- format_clust_res$prototypes
- clus_formatted <- format_clust_res$clusters
-
- res <- protolasso(X_df, y_df, 1:3, nlambda=80)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
- colnames(X_df_model)))
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
- testthat::expect_true(ncol(res$beta) <= 80)
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
- # Should get an error if we try to call protolasso on df2 with clusters
- # because df2 contains factors with more than two levels
- testthat::expect_error(protolasso(df2, y_df, 4:6, nlambda=70),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
-
- # Should be fine if no clusters are provided
- res <- protolasso(df2, y_df, nlambda=70)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
-
- # Get properly formatted clusters and prototypes for testing
- format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model),
- get_prototypes=TRUE, x=X_df_model, y=y_df)
-
- prototypes <- format_clust_res$prototypes
- clus_formatted <- format_clust_res$clusters
-
- res <- protolasso(X_df_model, y_df, 4:6, nlambda=70)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
- colnames(X_df_model)))
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
- testthat::expect_true(ncol(res$beta) <= 70)
-
-
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
-
- # Get properly formatted clusters and prototypes for testing
- format_clust_res <- formatClusters(clusters=good_clusters, p=11,
- clust_names=names(good_clusters),
- get_prototypes=TRUE, x=x2, y=y)
-
- prototypes <- format_clust_res$prototypes
- clus_formatted <- format_clust_res$clusters
-
- res <- protolasso(x2, y, good_clusters, nlambda=50)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
- LETTERS[1:11]))
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
-
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
- testthat::expect_true(ncol(res$beta) <= 50)
-
- # Bad inputs
- testthat::expect_error(protolasso(X="x", y=y[1:10], clusters=good_clusters,
- nlambda=10),
- "is.matrix(X) | is.data.frame(X) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y[1:10], clusters=good_clusters,
- nlambda=10),
- "n == length(y) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, 4:6),
- nlambda=10),
- "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE)
-
- # Duplicate clusters are now silently removed (#156); the fitted result for a
- # duplicated cluster is identical to passing the cluster once (seed both).
- set.seed(921)
- dup_pl <- protolasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10)
- set.seed(921)
- dedup_pl <- protolasso(X=x, y=y, clusters=list(2:3), nlambda=10)
- testthat::expect_identical(dup_pl, dedup_pl)
-
- testthat::expect_error(protolasso(X=x, y=y,
- clusters=list(1:4, as.integer(NA)),
- nlambda=10),
- "!is.na(clusters) are not all TRUE", fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)),
- nlambda=10),
- "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
- nlambda=1), "nlambda >= 2 is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
- nlambda=x),
- "length(nlambda) == 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
- nlambda="nlambda"),
- "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
- nlambda=10.5),
- "nlambda == round(nlambda) is not TRUE",
- fixed=TRUE)
-
- # (#127) A single all-encompassing cluster (or a genuine p < 2 input) leaves
- # glmnet with a 1-column design; clusterLassoCore now errors up front with a
- # cssr message naming both causes, instead of glmnet's "2 or more columns".
- testthat::expect_error(
- protolasso(X=x, y=y, clusters=list(all=1:11)),
- "need at least 2 cluster representatives to fit the lasso", fixed=TRUE)
-
-})
-## Test passed with 575 successes.
-Tests for clusterRepLasso():
-testthat::test_that("clusterRepLasso works", {
+
+ # Neither ncol nor nrow matches n_pen (66 on this design at nlambda = 100),
+ # so the reshaping cannot tell which orientation it is looking at and stops
+ # instead of guessing. No glmnet in play emits this, which is why the guard
+ # is otherwise unobserved.
+ testthat::local_mocked_bindings(
+ predict.glmnet = function(...) data.frame(a=1:2, b=3:4),
+ .package="glmnet")
+
+ testthat::expect_error(protolasso(x, y, good_clusters, nlambda=100),
+ "nrow(nonzero_mat) == n_pen is not TRUE", fixed=TRUE)
+})
+## Test passed with 1 success.
+Finally, tests for protolasso():
+testthat::test_that("protolasso works", {
set.seed(61282)
x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
@@ -2120,12 +1732,12 @@
prototypes <- format_clust_res$prototypes
clus_formatted <- format_clust_res$clusters
- res <- clusterRepLasso(x, y, good_clusters, nlambda=60)
+ res <- protolasso(x, y, good_clusters, nlambda=60)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("selected_sets",
"selected_clusts_list", "beta"))
-
+
# selected_sets
testthat::expect_true(is.list(res$selected_sets))
# Selected models should have one of each size without repetition
@@ -2181,23 +1793,23 @@
testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
testthat::expect_true(ncol(res$beta) <= 60)
-
+
# X as a data.frame
X_df <- datasets::mtcars
X_df_model <- stats::model.matrix(~ ., X_df)
X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
-
+
y_df <- rnorm(nrow(X_df))
-
+
# Get properly formatted clusters and prototypes for testing
format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model),
get_prototypes=TRUE, x=X_df_model, y=y_df)
-
+
prototypes <- format_clust_res$prototypes
clus_formatted <- format_clust_res$clusters
-
- res <- clusterRepLasso(X_df, y_df, 1:3, nlambda=80)
+
+ res <- protolasso(X_df, y_df, 1:3, nlambda=80)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("selected_sets",
@@ -2253,7 +1865,7 @@
testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
}
}
-
+
# beta
testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
@@ -2268,21 +1880,21 @@
df2$am <- as.factor(df2$am)
df2$gear <- as.factor(df2$gear)
df2$carb <- as.factor(df2$carb)
-
- # Should get an error if we try to call clusterRepLasso on df2 with clusters
- # because df2 contains factors with more than two levels
- testthat::expect_error(clusterRepLasso(df2, y_df, 4:6, nlambda=70),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
-
- # Should be fine if no clusters are provided
- res <- clusterRepLasso(df2, y_df, nlambda=70)
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ # Should get an error if we try to call protolasso on df2 with clusters
+ # because df2 contains factors with more than two levels
+ testthat::expect_error(protolasso(df2, y_df, 4:6, nlambda=70),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
- X_df_model <- stats::model.matrix(~ ., df2)
- X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+ # Should be fine if no clusters are provided
+ res <- protolasso(df2, y_df, nlambda=70)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
# Get properly formatted clusters and prototypes for testing
@@ -2292,7 +1904,7 @@
prototypes <- format_clust_res$prototypes
clus_formatted <- format_clust_res$clusters
- res <- clusterRepLasso(X_df_model, y_df, 4:6, nlambda=70)
+ res <- protolasso(X_df_model, y_df, 4:6, nlambda=70)
testthat::expect_true(is.list(res))
testthat::expect_identical(names(res), c("selected_sets",
@@ -2325,264 +1937,652 @@
clust_lengths <- lengths(res$selected_clusts_list)
clust_lengths <- clust_lengths[clust_lengths != 0]
testthat::expect_identical(clust_lengths, unique(clust_lengths))
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
- testthat::expect_true(ncol(res$beta) <= 70)
-
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
+ testthat::expect_true(ncol(res$beta) <= 70)
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
- # Get properly formatted clusters and prototypes for testing
- format_clust_res <- formatClusters(clusters=good_clusters, p=11,
- clust_names=names(good_clusters),
- get_prototypes=TRUE, x=x2, y=y)
-
- prototypes <- format_clust_res$prototypes
- clus_formatted <- format_clust_res$clusters
-
- res <- clusterRepLasso(x2, y, good_clusters, nlambda=50)
-
- testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("selected_sets",
- "selected_clusts_list", "beta"))
-
- # selected_sets
- testthat::expect_true(is.list(res$selected_sets))
- # Selected models should have one of each size without repetition
- lengths <- lengths(res$selected_sets)
- lengths <- lengths[lengths != 0]
- testthat::expect_identical(lengths, unique(lengths))
- for(i in 1:length(res$selected_sets)){
- if(!is.null(res$selected_sets[[i]])){
- testthat::expect_true(is.integer(res$selected_sets[[i]]))
- testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
- testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
- testthat::expect_equal(length(res$selected_sets[[i]]), i)
- testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
- LETTERS[1:11]))
- } else{
- testthat::expect_true(is.null(res$selected_sets[[i]]))
- }
- }
-
+
+ # Get properly formatted clusters and prototypes for testing
+ format_clust_res <- formatClusters(clusters=good_clusters, p=11,
+ clust_names=names(good_clusters),
+ get_prototypes=TRUE, x=x2, y=y)
+
+ prototypes <- format_clust_res$prototypes
+ clus_formatted <- format_clust_res$clusters
+
+ res <- protolasso(x2, y, good_clusters, nlambda=50)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
+ LETTERS[1:11]))
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
- # selected_clusts_list
- testthat::expect_true(is.list(res$selected_clusts_list))
- # Selected models should have one of each size without repetition
- clust_lengths <- lengths(res$selected_clusts_list)
- clust_lengths <- clust_lengths[clust_lengths != 0]
- testthat::expect_identical(clust_lengths, unique(clust_lengths))
-
- for(k in 1:length(res$selected_clusts_list)){
- if(!is.null(res$selected_clusts_list[[k]])){
- testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_sets[[k]]),
- length(res$selected_clusts_list[[k]]))
- testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
- sel_feats <- unlist(res$selected_clusts_list[[k]])
- testthat::expect_true(all(sel_feats %in% 1:11))
- testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
- n_clusts <- k
- for(i in 1:n_clusts){
- clust_i_found <- FALSE
- clust_i <- res$selected_clusts_list[[k]][[i]]
- for(j in 1:length(clus_formatted)){
- clust_i_found <- clust_i_found | identical(clust_i,
- clus_formatted[[j]])
- }
- testthat::expect_true(clust_i_found)
- }
- } else{
- testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
- }
- }
-
- # beta
- testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
- testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
- testthat::expect_true(ncol(res$beta) <= 50)
-
- # Bad inputs
- testthat::expect_error(clusterRepLasso(X="x", y=y[1:10], clusters=good_clusters,
- nlambda=10),
- "is.matrix(X) | is.data.frame(X) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y[1:10], clusters=good_clusters,
- nlambda=10),
- "n == length(y) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, 4:6),
- nlambda=10),
- "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE)
-
- # Duplicate clusters are now silently removed (#156); identical to passing the
- # cluster once (seed both).
- set.seed(921)
- dup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10)
- set.seed(921)
- dedup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3), nlambda=10)
- testthat::expect_identical(dup_crl, dedup_crl)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y,
- clusters=list(1:4, as.integer(NA)),
- nlambda=10),
- "!is.na(clusters) are not all TRUE", fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)),
- nlambda=10),
- "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
- nlambda=1), "nlambda >= 2 is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
- nlambda=x),
- "length(nlambda) == 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
- nlambda="nlambda"),
- "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
- nlambda=10.5),
- "nlambda == round(nlambda) is not TRUE",
- fixed=TRUE)
-
- # (#127) Same degenerate-design guard as protolasso: a single all-encompassing
- # cluster yields a 1-column design, now rejected with a clear cssr message
- # rather than glmnet's "2 or more columns".
- testthat::expect_error(
- clusterRepLasso(X=x, y=y, clusters=list(all=1:11)),
- "need at least 2 cluster representatives to fit the lasso", fixed=TRUE)
-
-})
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
+ testthat::expect_true(ncol(res$beta) <= 50)
+
+ # Bad inputs
+ testthat::expect_error(protolasso(X="x", y=y[1:10], clusters=good_clusters,
+ nlambda=10),
+ "is.matrix(X) | is.data.frame(X) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y[1:10], clusters=good_clusters,
+ nlambda=10),
+ "n == length(y) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=list(1:4, 4:6),
+ nlambda=10),
+ "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE)
+
+ # Duplicate clusters are now silently removed (#156); the fitted result for a
+ # duplicated cluster is identical to passing the cluster once (seed both).
+ set.seed(921)
+ dup_pl <- protolasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10)
+ set.seed(921)
+ dedup_pl <- protolasso(X=x, y=y, clusters=list(2:3), nlambda=10)
+ testthat::expect_identical(dup_pl, dedup_pl)
+
+ testthat::expect_error(protolasso(X=x, y=y,
+ clusters=list(1:4, as.integer(NA)),
+ nlambda=10),
+ "!is.na(clusters) are not all TRUE", fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)),
+ nlambda=10),
+ "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
+ nlambda=1), "nlambda >= 2 is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
+ nlambda=x),
+ "length(nlambda) == 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
+ nlambda="nlambda"),
+ "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(protolasso(X=x, y=y, clusters=good_clusters,
+ nlambda=10.5),
+ "nlambda == round(nlambda) is not TRUE",
+ fixed=TRUE)
+
+ # (#127) A single all-encompassing cluster (or a genuine p < 2 input) leaves
+ # glmnet with a 1-column design; clusterLassoCore now errors up front with a
+ # cssr message naming both causes, instead of glmnet's "2 or more columns".
+ testthat::expect_error(
+ protolasso(X=x, y=y, clusters=list(all=1:11)),
+ "need at least 2 cluster representatives to fit the lasso", fixed=TRUE)
+
+})## Test passed with 575 successes.Tests for clusterRepLasso():
testthat::test_that("clusterRepLasso works", {
+ set.seed(61282)
+
+ x <- matrix(stats::rnorm(15*11), nrow=15, ncol=11)
+ y <- stats::rnorm(15)
+
+ good_clusters <- list(red_cluster=1L:4L, green_cluster=5L:8L)
+
+ # Get properly formatted clusters and prototypes for testing
+ format_clust_res <- formatClusters(clusters=good_clusters, p=11,
+ clust_names=names(good_clusters),
+ get_prototypes=TRUE, x=x, y=y)
+
+ prototypes <- format_clust_res$prototypes
+ clus_formatted <- format_clust_res$clusters
+
+ res <- clusterRepLasso(x, y, good_clusters, nlambda=60)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ testthat::expect_true(is.null(names(res$selected_sets[[i]])))
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
+ testthat::expect_true(ncol(res$beta) <= 60)
+
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+
+ X_df_model <- stats::model.matrix(~ ., X_df)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+ y_df <- rnorm(nrow(X_df))
+
+ # Get properly formatted clusters and prototypes for testing
+ format_clust_res <- formatClusters(clusters=1:3, p=ncol(X_df_model),
+ get_prototypes=TRUE, x=X_df_model, y=y_df)
+
+ prototypes <- format_clust_res$prototypes
+ clus_formatted <- format_clust_res$clusters
+
+ res <- clusterRepLasso(X_df, y_df, 1:3, nlambda=80)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
+ colnames(X_df_model)))
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
+ testthat::expect_true(ncol(res$beta) <= 80)
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ # Should get an error if we try to call clusterRepLasso on df2 with clusters
+ # because df2 contains factors with more than two levels
+ testthat::expect_error(clusterRepLasso(df2, y_df, 4:6, nlambda=70),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+
+ # Should be fine if no clusters are provided
+ res <- clusterRepLasso(df2, y_df, nlambda=70)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+ X_df_model <- stats::model.matrix(~ ., df2)
+ X_df_model <- X_df_model[, colnames(X_df_model) != "(Intercept)"]
+
+
+ # Get properly formatted clusters and prototypes for testing
+ format_clust_res <- formatClusters(clusters=4:6, p=ncol(X_df_model),
+ get_prototypes=TRUE, x=X_df_model, y=y_df)
+
+ prototypes <- format_clust_res$prototypes
+ clus_formatted <- format_clust_res$clusters
+
+ res <- clusterRepLasso(X_df_model, y_df, 4:6, nlambda=70)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
+ colnames(X_df_model)))
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:ncol(X_df_model)))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == ncol(X_df_model) - 3 + 1)
+ testthat::expect_true(ncol(res$beta) <= 70)
+
+
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+
+ # Get properly formatted clusters and prototypes for testing
+ format_clust_res <- formatClusters(clusters=good_clusters, p=11,
+ clust_names=names(good_clusters),
+ get_prototypes=TRUE, x=x2, y=y)
+
+ prototypes <- format_clust_res$prototypes
+ clus_formatted <- format_clust_res$clusters
+
+ res <- clusterRepLasso(x2, y, good_clusters, nlambda=50)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_identical(names(res), c("selected_sets",
+ "selected_clusts_list", "beta"))
+
+ # selected_sets
+ testthat::expect_true(is.list(res$selected_sets))
+ # Selected models should have one of each size without repetition
+ lengths <- lengths(res$selected_sets)
+ lengths <- lengths[lengths != 0]
+ testthat::expect_identical(lengths, unique(lengths))
+ for(i in 1:length(res$selected_sets)){
+ if(!is.null(res$selected_sets[[i]])){
+ testthat::expect_true(is.integer(res$selected_sets[[i]]))
+ testthat::expect_true(all(!is.na(res$selected_sets[[i]])))
+ testthat::expect_true(all(res$selected_sets[[i]] %in% prototypes))
+ testthat::expect_equal(length(res$selected_sets[[i]]), i)
+ testthat::expect_true(all(names(res$selected_sets[[i]]) %in%
+ LETTERS[1:11]))
+ } else{
+ testthat::expect_true(is.null(res$selected_sets[[i]]))
+ }
+ }
+
+
+ # selected_clusts_list
+ testthat::expect_true(is.list(res$selected_clusts_list))
+ # Selected models should have one of each size without repetition
+ clust_lengths <- lengths(res$selected_clusts_list)
+ clust_lengths <- clust_lengths[clust_lengths != 0]
+ testthat::expect_identical(clust_lengths, unique(clust_lengths))
+
+ for(k in 1:length(res$selected_clusts_list)){
+ if(!is.null(res$selected_clusts_list[[k]])){
+ testthat::expect_true(is.list(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_sets[[k]]),
+ length(res$selected_clusts_list[[k]]))
+ testthat::expect_equal(length(res$selected_clusts_list[[k]]), k)
+ sel_feats <- unlist(res$selected_clusts_list[[k]])
+ testthat::expect_true(all(sel_feats %in% 1:11))
+ testthat::expect_equal(length(sel_feats), length(unique(sel_feats)))
+ n_clusts <- k
+ for(i in 1:n_clusts){
+ clust_i_found <- FALSE
+ clust_i <- res$selected_clusts_list[[k]][[i]]
+ for(j in 1:length(clus_formatted)){
+ clust_i_found <- clust_i_found | identical(clust_i,
+ clus_formatted[[j]])
+ }
+ testthat::expect_true(clust_i_found)
+ }
+ } else{
+ testthat::expect_true(is.null(res$selected_clusts_list[[k]]))
+ }
+ }
+
+ # beta
+ testthat::expect_true(grepl("dgCMatrix", class(res$beta)))
+ testthat::expect_true(nrow(res$beta) == 11 - 8 + 2)
+ testthat::expect_true(ncol(res$beta) <= 50)
+
+ # Bad inputs
+ testthat::expect_error(clusterRepLasso(X="x", y=y[1:10], clusters=good_clusters,
+ nlambda=10),
+ "is.matrix(X) | is.data.frame(X) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y[1:10], clusters=good_clusters,
+ nlambda=10),
+ "n == length(y) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(1:4, 4:6),
+ nlambda=10),
+ "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.", fixed=TRUE)
+
+ # Duplicate clusters are now silently removed (#156); identical to passing the
+ # cluster once (seed both).
+ set.seed(921)
+ dup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3, 2:3), nlambda=10)
+ set.seed(921)
+ dedup_crl <- clusterRepLasso(X=x, y=y, clusters=list(2:3), nlambda=10)
+ testthat::expect_identical(dup_crl, dedup_crl)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y,
+ clusters=list(1:4, as.integer(NA)),
+ nlambda=10),
+ "!is.na(clusters) are not all TRUE", fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=list(2:3, c(4, 4, 5)),
+ nlambda=10),
+ "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
+ nlambda=1), "nlambda >= 2 is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
+ nlambda=x),
+ "length(nlambda) == 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
+ nlambda="nlambda"),
+ "is.numeric(nlambda) | is.integer(nlambda) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(clusterRepLasso(X=x, y=y, clusters=good_clusters,
+ nlambda=10.5),
+ "nlambda == round(nlambda) is not TRUE",
+ fixed=TRUE)
+
+ # (#127) Same degenerate-design guard as protolasso: a single all-encompassing
+ # cluster yields a 1-column design, now rejected with a clear cssr message
+ # rather than glmnet's "2 or more columns".
+ testthat::expect_error(
+ clusterRepLasso(X=x, y=y, clusters=list(all=1:11)),
+ "need at least 2 cluster representatives to fit the lasso", fixed=TRUE)
+
+})## Test passed with 527 successes.Regression test for the empty-lasso-path edge case (#157):
-testthat::test_that("protolasso/clusterRepLasso return an empty selection when the lasso path selects nothing (#157)", {
- # X'y must be EXACTLY zero to empty the whole glmnet path (see plan note:
- # floating-point orthogonality drives lambda_max->0 and selects everything).
- # Paired +1/-1 integer rows give crossprod(X, y) == 0 exactly.
- y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1))
- X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0),
- c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1))
- storage.mode(X) <- "double"
- testthat::expect_identical(max(abs(crossprod(X, y))), 0) # exactly orthogonal
-
- # Was: crash "model_size > 0 is not TRUE". Now: empty selection, no error.
- res_p <- protolasso(X, y)
- testthat::expect_length(res_p$selected_sets, 0)
- testthat::expect_length(res_p$selected_clusts_list, 0)
-
- res_c <- clusterRepLasso(X, y)
- testthat::expect_length(res_c$selected_sets, 0)
- testthat::expect_length(res_c$selected_clusts_list, 0)
-
- # A normal signal case still selects features (guards against over-fixing).
- set.seed(2)
- Xs <- matrix(stats::rnorm(24 * 4), 24, 4)
- ys <- Xs[, 1] * 2 + stats::rnorm(24, sd = 0.1)
- testthat::expect_gt(length(protolasso(Xs, ys)$selected_sets), 0)
-})testthat::test_that("protolasso/clusterRepLasso return an empty selection when the lasso path selects nothing (#157)", {
+ # X'y must be EXACTLY zero to empty the whole glmnet path (see plan note:
+ # floating-point orthogonality drives lambda_max->0 and selects everything).
+ # Paired +1/-1 integer rows give crossprod(X, y) == 0 exactly.
+ y <- as.double(c(1, 1, 1, 1, -1, -1, -1, -1))
+ X <- cbind(c(1,-1,0,0,0,0,0,0), c(0,0,1,-1,0,0,0,0),
+ c(0,0,0,0,1,-1,0,0), c(0,0,0,0,0,0,1,-1))
+ storage.mode(X) <- "double"
+ testthat::expect_identical(max(abs(crossprod(X, y))), 0) # exactly orthogonal
+
+ # Was: crash "model_size > 0 is not TRUE". Now: empty selection, no error.
+ res_p <- protolasso(X, y)
+ testthat::expect_length(res_p$selected_sets, 0)
+ testthat::expect_length(res_p$selected_clusts_list, 0)
+
+ res_c <- clusterRepLasso(X, y)
+ testthat::expect_length(res_c$selected_sets, 0)
+ testthat::expect_length(res_c$selected_clusts_list, 0)
+
+ # A normal signal case still selects features (guards against over-fixing).
+ set.seed(2)
+ Xs <- matrix(stats::rnorm(24 * 4), 24, 4)
+ ys <- Xs[, 1] * 2 + stats::rnorm(24, sd = 0.1)
+ testthat::expect_gt(length(protolasso(Xs, ys)$selected_sets), 0)
+})## Test passed with 6 successes.Regression tests for the named output contract of protolasso()/clusterRepLasso(): selected_clusts_list[[k]] is a named list of the selected clusters (#158a).
testthat::test_that("protolasso and clusterRepLasso name selected_clusts_list with the selected clusters' names (#158a)", {
- set.seed(158)
- n <- 40L
- p <- 6L
- X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
- y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n))
- clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L))
- # formatClusters reorders to clustA, clustB, then one singleton per unclustered
- # feature in ascending order (c3 = feature 1, c4 = feature 3).
- expected_names <- c("clustA", "clustB", "c3", "c4")
-
- for (fun in list(protolasso, clusterRepLasso)) {
- res <- fun(X, y, clusters)
- testthat::expect_true(any(lengths(res$selected_clusts_list) > 0))
- for (k in seq_along(res$selected_clusts_list)) {
- sk <- res$selected_clusts_list[[k]]
- if (length(sk) > 0) {
- testthat::expect_false(is.null(names(sk)))
- testthat::expect_equal(length(names(sk)), k)
- testthat::expect_true(all(names(sk) %in% expected_names))
- # Name-based indexing returns the same cluster as position-based.
- testthat::expect_identical(sk[[names(sk)[1]]], sk[[1]])
- }
- }
- }
-})## Test passed with 26 successes.The rows of beta carry the reordered cluster names, so they cross-reference selected_clusts_list (#158b).
testthat::test_that("protolasso and clusterRepLasso beta carries cluster names as rownames (#158b)", {
+testthat::test_that("protolasso and clusterRepLasso name selected_clusts_list with the selected clusters' names (#158a)", {
set.seed(158)
n <- 40L
p <- 6L
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n))
clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L))
- expected_names <- c("clustA", "clustB", "c3", "c4")
-
- for (fun in list(protolasso, clusterRepLasso)) {
- res <- fun(X, y, clusters)
- # GUARANTEED equality: one beta row per reordered cluster, in order.
- testthat::expect_identical(rownames(res$beta), expected_names)
- # SUBSET cross-check: each selected cluster's name is among beta's rownames
- # (a never-selected cluster is still a beta row, so this is not equality).
- for (k in seq_along(res$selected_clusts_list)) {
- sk <- res$selected_clusts_list[[k]]
- if (length(sk) > 0) {
- testthat::expect_true(all(names(sk) %in% rownames(res$beta)))
- }
- }
- }
-})
-## Test passed with 8 successes.
-processClusterLassoInputs() rejects an X whose columns are partly named and partly NA-named, with the corrected remedy message (#158d).
-testthat::test_that("processClusterLassoInputs rejects X with mixed named and NA-named columns (#158d)", {
+ # formatClusters reorders to clustA, clustB, then one singleton per unclustered
+ # feature in ascending order (c3 = feature 1, c4 = feature 3).
+ expected_names <- c("clustA", "clustB", "c3", "c4")
+
+ for (fun in list(protolasso, clusterRepLasso)) {
+ res <- fun(X, y, clusters)
+ testthat::expect_true(any(lengths(res$selected_clusts_list) > 0))
+ for (k in seq_along(res$selected_clusts_list)) {
+ sk <- res$selected_clusts_list[[k]]
+ if (length(sk) > 0) {
+ testthat::expect_false(is.null(names(sk)))
+ testthat::expect_equal(length(names(sk)), k)
+ testthat::expect_true(all(names(sk) %in% expected_names))
+ # Name-based indexing returns the same cluster as position-based.
+ testthat::expect_identical(sk[[names(sk)[1]]], sk[[1]])
+ }
+ }
+ }
+})
+## Test passed with 26 successes.
+The rows of beta carry the reordered cluster names, so they cross-reference selected_clusts_list (#158b).
+testthat::test_that("protolasso and clusterRepLasso beta carries cluster names as rownames (#158b)", {
set.seed(158)
- n <- 20L
- p <- 4L
+ n <- 40L
+ p <- 6L
X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
- colnames(X) <- c("g1", NA, "g3", NA)
- y <- stats::rnorm(n)
- testthat::expect_error(
- processClusterLassoInputs(X = X, y = y, clusters = list(), nlambda = 10),
- "please either name all features in X or remove the names altogether",
- fixed = TRUE)
-})
+ y <- as.numeric(X %*% c(1, 0, 1, 0, 1, 0) + stats::rnorm(n))
+ clusters <- list(clustA = c(2L, 5L), clustB = c(4L, 6L))
+ expected_names <- c("clustA", "clustB", "c3", "c4")
+
+ for (fun in list(protolasso, clusterRepLasso)) {
+ res <- fun(X, y, clusters)
+ # GUARANTEED equality: one beta row per reordered cluster, in order.
+ testthat::expect_identical(rownames(res$beta), expected_names)
+ # SUBSET cross-check: each selected cluster's name is among beta's rownames
+ # (a never-selected cluster is still a beta row, so this is not equality).
+ for (k in seq_along(res$selected_clusts_list)) {
+ sk <- res$selected_clusts_list[[k]]
+ if (length(sk) > 0) {
+ testthat::expect_true(all(names(sk) %in% rownames(res$beta)))
+ }
+ }
+ }
+})## Test passed with 8 successes.processClusterLassoInputs() rejects an X whose columns are partly named and partly NA-named, with the corrected remedy message (#158d).
testthat::test_that("processClusterLassoInputs rejects X with mixed named and NA-named columns (#158d)", {
+ set.seed(158)
+ n <- 20L
+ p <- 4L
+ X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
+ colnames(X) <- c("g1", NA, "g3", NA)
+ y <- stats::rnorm(n)
+ testthat::expect_error(
+ processClusterLassoInputs(X = X, y = y, clusters = list(), nlambda = 10),
+ "please either name all features in X or remove the names altogether",
+ fixed = TRUE)
+})## Test passed with 1 success.Tests for checkGenClusteredDataInputs()
testthat::test_that("checkGenClusteredDataInputs works", {
- set.seed(7612)
-
- # Should get no error
- checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
-
- checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=1, sigma_eps_sq=NA)
-
- # sig_clusters
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters="2", rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=4, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "sig_clusters <= n_clusters is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=-1, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "sig_clusters >= 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=.6, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "sig_clusters == round(sig_clusters) is not TRUE",
- fixed=TRUE)
-
-
- # n_clusters
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5,
- n_clusters="3",
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3.2,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "n_clusters == round(n_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=0,
- sig_clusters=0, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "n_clusters >= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=1, n_clusters=3,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "cluster_size >= 2 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=16, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "p >= n_clusters * cluster_size + k_unclustered is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "rho > 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=0,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "beta_latent != 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=0, snr=1,
- sigma_eps_sq=NA),
- "beta_unclustered != 0 is not TRUE", fixed=TRUE)
-
- # k_unclustered
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered="2",
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=0,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "k_unclustered >= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2.2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "k_unclustered == round(k_unclustered) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=NA,
- sigma_eps_sq=NA),
- "Must specify one of snr or sigma_eps_sq", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=-.2,
- sigma_eps_sq=NA),
- "snr > 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=NA,
- sigma_eps_sq=-.3),
- "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
-
-})testthat::test_that("checkGenClusteredDataInputs works", {
+ set.seed(7612)
+
+ # Should get no error
+ checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+
+ checkGenClusteredDataInputs(p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=1, sigma_eps_sq=NA)
+
+ # sig_clusters
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters="2", rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=4, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "sig_clusters <= n_clusters is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=-1, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "sig_clusters >= 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=.6, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "sig_clusters == round(sig_clusters) is not TRUE",
+ fixed=TRUE)
+
+
+ # n_clusters
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5,
+ n_clusters="3",
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3.2,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "n_clusters == round(n_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=0,
+ sig_clusters=0, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "n_clusters >= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=1, n_clusters=3,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "cluster_size >= 2 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=16, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "p >= n_clusters * cluster_size + k_unclustered is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "rho > 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=0,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "beta_latent != 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=0, snr=1,
+ sigma_eps_sq=NA),
+ "beta_unclustered != 0 is not TRUE", fixed=TRUE)
+
+ # k_unclustered
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered="2",
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=0,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "k_unclustered >= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2.2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "k_unclustered == round(k_unclustered) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=NA,
+ sigma_eps_sq=NA),
+ "Must specify one of snr or sigma_eps_sq", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=-.2,
+ sigma_eps_sq=NA),
+ "snr > 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(checkGenClusteredDataInputs(p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=NA,
+ sigma_eps_sq=-.3),
+ "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
+
+})## Test passed with 18 successes.Tests for getNoiseVar():
testthat::test_that("getNoiseVar works", {
- # getNoiseVar(rho) returns the noise variance v such that a proxy Z + N(0, v)
- # has correlation rho with Z, i.e. v = 1/rho^2 - 1 (vectorized; rho in (0, 1]).
- testthat::expect_equal(getNoiseVar(1), 0)
- testthat::expect_equal(getNoiseVar(0.5), 3)
- testthat::expect_equal(getNoiseVar(0.9), 1/0.81 - 1)
- testthat::expect_equal(getNoiseVar(c(0.5, 1, 0.9)), c(3, 0, 1/0.81 - 1))
- # The defining property: a proxy with this noise variance has correlation rho.
- testthat::expect_equal(1/sqrt(1 + getNoiseVar(0.8)), 0.8)
-
- # rho must be numeric, non-NA, non-empty, and in (0, 1] (checks are vectorized).
- testthat::expect_error(getNoiseVar(0), "all(rho > 0) is not TRUE", fixed=TRUE)
- testthat::expect_error(getNoiseVar(-0.5), "all(rho > 0) is not TRUE",
- fixed=TRUE)
- testthat::expect_error(getNoiseVar(c(0.5, 0)), "all(rho > 0) is not TRUE",
- fixed=TRUE)
- testthat::expect_error(getNoiseVar(1.5), "all(rho <= 1) is not TRUE",
- fixed=TRUE)
- testthat::expect_error(getNoiseVar(NA_real_), "all(!is.na(rho)) is not TRUE",
- fixed=TRUE)
- testthat::expect_error(getNoiseVar("0.5"),
- "is.numeric(rho) | is.integer(rho) is not TRUE", fixed=TRUE)
- testthat::expect_error(getNoiseVar(numeric(0)), "length(rho) >= 1 is not TRUE",
- fixed=TRUE)
-})testthat::test_that("getNoiseVar works", {
+ # getNoiseVar(rho) returns the noise variance v such that a proxy Z + N(0, v)
+ # has correlation rho with Z, i.e. v = 1/rho^2 - 1 (vectorized; rho in (0, 1]).
+ testthat::expect_equal(getNoiseVar(1), 0)
+ testthat::expect_equal(getNoiseVar(0.5), 3)
+ testthat::expect_equal(getNoiseVar(0.9), 1/0.81 - 1)
+ testthat::expect_equal(getNoiseVar(c(0.5, 1, 0.9)), c(3, 0, 1/0.81 - 1))
+ # The defining property: a proxy with this noise variance has correlation rho.
+ testthat::expect_equal(1/sqrt(1 + getNoiseVar(0.8)), 0.8)
+
+ # rho must be numeric, non-NA, non-empty, and in (0, 1] (checks are vectorized).
+ testthat::expect_error(getNoiseVar(0), "all(rho > 0) is not TRUE", fixed=TRUE)
+ testthat::expect_error(getNoiseVar(-0.5), "all(rho > 0) is not TRUE",
+ fixed=TRUE)
+ testthat::expect_error(getNoiseVar(c(0.5, 0)), "all(rho > 0) is not TRUE",
+ fixed=TRUE)
+ testthat::expect_error(getNoiseVar(1.5), "all(rho <= 1) is not TRUE",
+ fixed=TRUE)
+ testthat::expect_error(getNoiseVar(NA_real_), "all(!is.na(rho)) is not TRUE",
+ fixed=TRUE)
+ testthat::expect_error(getNoiseVar("0.5"),
+ "is.numeric(rho) | is.integer(rho) is not TRUE", fixed=TRUE)
+ testthat::expect_error(getNoiseVar(numeric(0)), "length(rho) >= 1 is not TRUE",
+ fixed=TRUE)
+})## Test passed with 12 successes.Finally, tests for genClusteredData()
testthat::test_that("genClusteredData works", {
- set.seed(23478)
-
- ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho=.99,
- beta_latent=1.5, beta_unclustered=-2, snr=NA,
- sigma_eps_sq=.5)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- testthat::expect_true(is.numeric(ret$X))
- testthat::expect_true(is.matrix(ret$X))
- testthat::expect_equal(ncol(ret$X), 19)
- testthat::expect_equal(nrow(ret$X), 25)
- # X is Gaussian with mean 0 and variance 4; expect all observations to lie
- # within 5 standard deviations of mean
- testthat::expect_true(all(abs(ret$X) < 5*2))
- # Test that clusters are correlated--within-cluster correlation should be
- # high, correlation with other features should be low
- testthat::expect_true(min(cor(ret$X[, 1:5])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6)
-
- testthat::expect_true(min(cor(ret$X[, 6:10])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 6:10],
- ret$X[, c(1:5, 11:19)]))) < .6)
-
- testthat::expect_true(min(cor(ret$X[, 11:15])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 11:15],
- ret$X[, c(1:10, 16:19)]))) < .6)
-
- cor_indeps <- cor(ret$X[, 16:19])
- testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6)
-
- testthat::expect_true(is.numeric(ret$y))
- testthat::expect_equal(length(ret$y), 25)
-
- testthat::expect_true(is.numeric(ret$Z))
- testthat::expect_true(is.matrix(ret$Z))
- testthat::expect_equal(nrow(ret$Z), 25)
- testthat::expect_equal(ncol(ret$Z), 3)
-
- testthat::expect_true(is.numeric(ret$mu))
- testthat::expect_equal(length(ret$mu), 25)
- # Because y is Gaussian with mean mu and standard deviation .5 conditional on
- # mu, expect all observations to lie within 5 sds of mu
- testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5))
-
- # Specify SNR instead of sigma_eps_sq
- ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=1, sigma_eps_sq=NA)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of
- # the two may be given.
- testthat::expect_error(
- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=.01, sigma_eps_sq=.25),
- "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE)
-
- # Try a single latent variable (z should be a one-column matrix)
- ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- testthat::expect_true(is.numeric(ret$Z))
- testthat::expect_true(is.matrix(ret$Z))
- testthat::expect_equal(nrow(ret$Z), 5)
- testthat::expect_equal(ncol(ret$Z), 1)
-
- # Bad inputs
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters="2", rho=.8,
- beta_latent=1.5, beta_unclustered=-2,
- snr=1, sigma_eps_sq=NA),
- "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=4, rho=.8,
- beta_latent=1.5, beta_unclustered=-2,
- snr=1, sigma_eps_sq=NA),
- "sig_clusters <= n_clusters is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=-1, rho=.8,
- beta_latent=1.5, beta_unclustered=-2,
- snr=1, sigma_eps_sq=NA),
- "sig_clusters >= 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=.6, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "sig_clusters == round(sig_clusters) is not TRUE",
- fixed=TRUE)
-
-
- # n_clusters
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5,
- n_clusters="3",
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3.2,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "n_clusters == round(n_clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=0,
- sig_clusters=0, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "n_clusters >= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=1, n_clusters=3,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "cluster_size >= 2 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(p=16, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "p >= n_clusters * cluster_size + k_unclustered is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "rho > 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=0,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "beta_latent != 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=0, snr=1,
- sigma_eps_sq=NA),
- "beta_unclustered != 0 is not TRUE", fixed=TRUE)
-
- # k_unclustered
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered="2",
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=0,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "k_unclustered >= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2.2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=1,
- sigma_eps_sq=NA),
- "k_unclustered == round(k_unclustered) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=NA,
- sigma_eps_sq=NA),
- "Must specify one of snr or sigma_eps_sq", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=-.2,
- sigma_eps_sq=NA),
- "snr > 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3,
- sig_clusters=2, rho=0.8,
- beta_latent=1.5,
- beta_unclustered=-2, snr=NA,
- sigma_eps_sq=-.3),
- "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
-
- # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu)
- ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq=0)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ret$y, ret$mu)
-
- # k_unclustered = 1 is allowed (issue #13)
- ret <- genClusteredData(n=5, p=19, k_unclustered=1, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_equal(nrow(ret$X), 5)
- testthat::expect_equal(ncol(ret$X), 19)
-
-})## Test passed with 57 successes.Tests for genClusteredDataWeighted()
testthat::test_that("genClusteredDataWeighted works", {
+testthat::test_that("genClusteredData works", {
set.seed(23478)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=.5)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- testthat::expect_true(is.numeric(ret$X))
- testthat::expect_true(is.matrix(ret$X))
- testthat::expect_equal(ncol(ret$X), 19)
- testthat::expect_equal(nrow(ret$X), 25)
- # X is Gaussian with mean 0 and variance 4; expect all observations to lie
- # within 5 standard deviations of mean
- testthat::expect_true(all(abs(ret$X) < 5*2))
- # Test that clusters are correlated--within-cluster correlation should be
- # high, correlation with other features should be low
- testthat::expect_true(min(cor(ret$X[, 1:3])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6)
-
- testthat::expect_true(min(cor(ret$X[, 6:8])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 6:10],
- ret$X[, c(1:5, 11:19)]))) < .6)
-
- testthat::expect_true(min(cor(ret$X[, 11:13])) > .9)
- testthat::expect_true(max(abs(cor(ret$X[, 11:15],
- ret$X[, c(1:10, 16:19)]))) < .7)
-
- cor_indeps <- cor(ret$X[, 16:19])
- testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6)
-
- testthat::expect_true(is.numeric(ret$y))
- testthat::expect_equal(length(ret$y), 25)
-
- testthat::expect_true(is.numeric(ret$Z))
- testthat::expect_true(is.matrix(ret$Z))
- testthat::expect_equal(nrow(ret$Z), 25)
- testthat::expect_equal(ncol(ret$Z), 3)
-
- testthat::expect_true(is.numeric(ret$mu))
- testthat::expect_equal(length(ret$mu), 25)
- # Because y is Gaussian with mean mu and standard deviation .5 conditional on
- # mu, expect all observations to lie within 5 sds of mu
- testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5))
-
- # Specify SNR instead of sigma_eps_sq
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=1, sigma_eps_sq=NA)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of
- # the two may be given.
- testthat::expect_error(
- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=.01, sigma_eps_sq=.25),
- "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE)
-
- # Try a single latent variable (z should be a one-column matrix)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=1,
- sig_clusters=1, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=.5)
-
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-
- testthat::expect_true(is.numeric(ret$Z))
- testthat::expect_true(is.matrix(ret$Z))
- testthat::expect_equal(nrow(ret$Z), 25)
- testthat::expect_equal(ncol(ret$Z), 1)
-
- # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=0)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ret$y, ret$mu)
-
- # k_unclustered = 1 is allowed (issue #13)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=1, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=.5)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ncol(ret$X), 19)
-
-})
-## Test passed with 38 successes.
-Tests for genClusteredDataWeightedRandom()
-testthat::test_that("genClusteredDataWeightedRandom works", {
+ ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho=.99,
+ beta_latent=1.5, beta_unclustered=-2, snr=NA,
+ sigma_eps_sq=.5)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ testthat::expect_true(is.numeric(ret$X))
+ testthat::expect_true(is.matrix(ret$X))
+ testthat::expect_equal(ncol(ret$X), 19)
+ testthat::expect_equal(nrow(ret$X), 25)
+ # X is Gaussian with mean 0 and variance 4; expect all observations to lie
+ # within 5 standard deviations of mean
+ testthat::expect_true(all(abs(ret$X) < 5*2))
+ # Test that clusters are correlated--within-cluster correlation should be
+ # high, correlation with other features should be low
+ testthat::expect_true(min(cor(ret$X[, 1:5])) > .9)
+ testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6)
+
+ testthat::expect_true(min(cor(ret$X[, 6:10])) > .9)
+ testthat::expect_true(max(abs(cor(ret$X[, 6:10],
+ ret$X[, c(1:5, 11:19)]))) < .6)
+
+ testthat::expect_true(min(cor(ret$X[, 11:15])) > .9)
+ testthat::expect_true(max(abs(cor(ret$X[, 11:15],
+ ret$X[, c(1:10, 16:19)]))) < .6)
+
+ cor_indeps <- cor(ret$X[, 16:19])
+ testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6)
+
+ testthat::expect_true(is.numeric(ret$y))
+ testthat::expect_equal(length(ret$y), 25)
+
+ testthat::expect_true(is.numeric(ret$Z))
+ testthat::expect_true(is.matrix(ret$Z))
+ testthat::expect_equal(nrow(ret$Z), 25)
+ testthat::expect_equal(ncol(ret$Z), 3)
+
+ testthat::expect_true(is.numeric(ret$mu))
+ testthat::expect_equal(length(ret$mu), 25)
+ # Because y is Gaussian with mean mu and standard deviation .5 conditional on
+ # mu, expect all observations to lie within 5 sds of mu
+ testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5))
+
+ # Specify SNR instead of sigma_eps_sq
+ ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=1, sigma_eps_sq=NA)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of
+ # the two may be given.
+ testthat::expect_error(
+ genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=.01, sigma_eps_sq=.25),
+ "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE)
+
+ # Try a single latent variable (z should be a one-column matrix)
+ ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ testthat::expect_true(is.numeric(ret$Z))
+ testthat::expect_true(is.matrix(ret$Z))
+ testthat::expect_equal(nrow(ret$Z), 5)
+ testthat::expect_equal(ncol(ret$Z), 1)
+
+ # Bad inputs
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters="2", rho=.8,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=1, sigma_eps_sq=NA),
+ "is.numeric(sig_clusters) | is.integer(sig_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=4, rho=.8,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=1, sigma_eps_sq=NA),
+ "sig_clusters <= n_clusters is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=-1, rho=.8,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=1, sigma_eps_sq=NA),
+ "sig_clusters >= 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=.6, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "sig_clusters == round(sig_clusters) is not TRUE",
+ fixed=TRUE)
+
+
+ # n_clusters
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5,
+ n_clusters="3",
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "is.numeric(n_clusters) | is.integer(n_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3.2,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "n_clusters == round(n_clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=0,
+ sig_clusters=0, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "n_clusters >= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=1, n_clusters=3,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "cluster_size >= 2 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(p=16, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "p >= n_clusters * cluster_size + k_unclustered is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "rho > 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=0,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "beta_latent != 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=0, snr=1,
+ sigma_eps_sq=NA),
+ "beta_unclustered != 0 is not TRUE", fixed=TRUE)
+
+ # k_unclustered
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered="2",
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "is.numeric(k_unclustered) | is.integer(k_unclustered) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=0,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "k_unclustered >= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2.2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=1,
+ sigma_eps_sq=NA),
+ "k_unclustered == round(k_unclustered) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=NA,
+ sigma_eps_sq=NA),
+ "Must specify one of snr or sigma_eps_sq", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=-.2,
+ sigma_eps_sq=NA),
+ "snr > 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(genClusteredData(n=5, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3,
+ sig_clusters=2, rho=0.8,
+ beta_latent=1.5,
+ beta_unclustered=-2, snr=NA,
+ sigma_eps_sq=-.3),
+ "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
+
+ # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu)
+ ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq=0)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ret$y, ret$mu)
+
+ # k_unclustered = 1 is allowed (issue #13)
+ ret <- genClusteredData(n=5, p=19, k_unclustered=1, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho=.8, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(nrow(ret$X), 5)
+ testthat::expect_equal(ncol(ret$X), 19)
+
+})
+## Test passed with 57 successes.
+Tests for genClusteredDataWeighted()
+testthat::test_that("genClusteredDataWeighted works", {
set.seed(23478)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3,
- sig_clusters=2, rho_high=1, rho_low=.5,
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
beta_latent=1.5, beta_unclustered=-2,
snr=NA, sigma_eps_sq=.5)
@@ -746,14 +639,14 @@
testthat::expect_true(all(abs(ret$X) < 5*2))
# Test that clusters are correlated--within-cluster correlation should be
# high, correlation with other features should be low
- testthat::expect_true(min(cor(ret$X[, 1:3])) > .2)
+ testthat::expect_true(min(cor(ret$X[, 1:3])) > .9)
testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6)
- testthat::expect_true(min(cor(ret$X[, 6:8])) > .2)
+ testthat::expect_true(min(cor(ret$X[, 6:8])) > .9)
testthat::expect_true(max(abs(cor(ret$X[, 6:10],
ret$X[, c(1:5, 11:19)]))) < .6)
- testthat::expect_true(min(cor(ret$X[, 11:13])) > .2)
+ testthat::expect_true(min(cor(ret$X[, 11:13])) > .9)
testthat::expect_true(max(abs(cor(ret$X[, 11:15],
ret$X[, c(1:10, 16:19)]))) < .7)
@@ -775,9 +668,9 @@
testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5))
# Specify SNR instead of sigma_eps_sq
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3,
- sig_clusters=2, rho_high=1, rho_low=.5,
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
beta_latent=1.5, beta_unclustered=-2,
snr=1, sigma_eps_sq=NA)
@@ -787,17 +680,17 @@
# Specifying both snr and sigma_eps_sq is an error (issue #13): only one of
# the two may be given.
testthat::expect_error(
- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3,
- sig_clusters=2, rho_high=.99, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2,
- snr=.01, sigma_eps_sq=.25),
+ genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=.01, sigma_eps_sq=.25),
"Only one of snr and sigma_eps_sq may be specified", fixed=TRUE)
# Try a single latent variable (z should be a one-column matrix)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=1,
- sig_clusters=1, rho_high=1, rho_low=.5,
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=1,
+ sig_clusters=1, rho_high=.99, rho_low=.5,
beta_latent=1.5, beta_unclustered=-2,
snr=NA, sigma_eps_sq=.5)
@@ -810,9 +703,9 @@
testthat::expect_equal(ncol(ret$Z), 1)
# sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3,
- sig_clusters=2, rho_high=1, rho_low=.5,
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
beta_latent=1.5, beta_unclustered=-2,
snr=NA, sigma_eps_sq=0)
testthat::expect_true(is.list(ret))
@@ -820,9 +713,9 @@
testthat::expect_equal(ret$y, ret$mu)
# k_unclustered = 1 is allowed (issue #13)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=1, cluster_size=5,
- n_clusters=3,
- sig_clusters=2, rho_high=1, rho_low=.5,
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=1, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
beta_latent=1.5, beta_unclustered=-2,
snr=NA, sigma_eps_sq=.5)
testthat::expect_true(is.list(ret))
@@ -831,6 +724,113 @@
})
## Test passed with 38 successes.
+Tests for genClusteredDataWeightedRandom()
+testthat::test_that("genClusteredDataWeightedRandom works", {
+ set.seed(23478)
+
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3,
+ sig_clusters=2, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=.5)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ testthat::expect_true(is.numeric(ret$X))
+ testthat::expect_true(is.matrix(ret$X))
+ testthat::expect_equal(ncol(ret$X), 19)
+ testthat::expect_equal(nrow(ret$X), 25)
+ # X is Gaussian with mean 0 and variance 4; expect all observations to lie
+ # within 5 standard deviations of mean
+ testthat::expect_true(all(abs(ret$X) < 5*2))
+ # Test that clusters are correlated--within-cluster correlation should be
+ # high, correlation with other features should be low
+ testthat::expect_true(min(cor(ret$X[, 1:3])) > .2)
+ testthat::expect_true(max(abs(cor(ret$X[, 1:5], ret$X[, 6:19]))) < .6)
+
+ testthat::expect_true(min(cor(ret$X[, 6:8])) > .2)
+ testthat::expect_true(max(abs(cor(ret$X[, 6:10],
+ ret$X[, c(1:5, 11:19)]))) < .6)
+
+ testthat::expect_true(min(cor(ret$X[, 11:13])) > .2)
+ testthat::expect_true(max(abs(cor(ret$X[, 11:15],
+ ret$X[, c(1:10, 16:19)]))) < .7)
+
+ cor_indeps <- cor(ret$X[, 16:19])
+ testthat::expect_true(max(abs(cor_indeps[lower.tri(cor_indeps)])) < .6)
+
+ testthat::expect_true(is.numeric(ret$y))
+ testthat::expect_equal(length(ret$y), 25)
+
+ testthat::expect_true(is.numeric(ret$Z))
+ testthat::expect_true(is.matrix(ret$Z))
+ testthat::expect_equal(nrow(ret$Z), 25)
+ testthat::expect_equal(ncol(ret$Z), 3)
+
+ testthat::expect_true(is.numeric(ret$mu))
+ testthat::expect_equal(length(ret$mu), 25)
+ # Because y is Gaussian with mean mu and standard deviation .5 conditional on
+ # mu, expect all observations to lie within 5 sds of mu
+ testthat::expect_true(all(abs(ret$y - ret$mu) < 5*.5))
+
+ # Specify SNR instead of sigma_eps_sq
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3,
+ sig_clusters=2, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=1, sigma_eps_sq=NA)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ # Specifying both snr and sigma_eps_sq is an error (issue #13): only one of
+ # the two may be given.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3,
+ sig_clusters=2, rho_high=.99, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=.01, sigma_eps_sq=.25),
+ "Only one of snr and sigma_eps_sq may be specified", fixed=TRUE)
+
+ # Try a single latent variable (z should be a one-column matrix)
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=1,
+ sig_clusters=1, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=.5)
+
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+
+ testthat::expect_true(is.numeric(ret$Z))
+ testthat::expect_true(is.matrix(ret$Z))
+ testthat::expect_equal(nrow(ret$Z), 25)
+ testthat::expect_equal(ncol(ret$Z), 1)
+
+ # sigma_eps_sq = 0 is allowed (issue #13) and yields noiseless data (y == mu)
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3,
+ sig_clusters=2, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=0)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ret$y, ret$mu)
+
+ # k_unclustered = 1 is allowed (issue #13)
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=1, cluster_size=5,
+ n_clusters=3,
+ sig_clusters=2, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=.5)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ncol(ret$X), 19)
+
+})
+## Test passed with 38 successes.
Finally, characterization snapshots that pin the exact generated output of all
three genClusteredData* generators. The “… works” tests above only check
distributional properties (correlations, ranges), not the exact RNG draw order
@@ -838,169 +838,169 @@
column). These snapshots make the #16 consolidation of the generators and their
validators provably behavior-preserving; regenerate only if the data-generating
algorithm intentionally changes.
-# Characterization snapshots: pin the EXACT generated values (X / y / Z / mu)
-# under fixed seeds so the #16 consolidation of the genClusteredData* functions
-# and their validators is provably behavior-preserving. The existing "... works"
-# tests only check distributional properties (correlations, ranges), NOT the
-# exact RNG draw order, which differs across the three generators (bulk vs
-# per-column vs random-per-column). Regenerate ONLY if the data-generating
-# algorithm intentionally changes.
-
-testthat::test_that("genClusteredData output is byte-stable (characterization snapshot, #16)", {
- set.seed(23478)
- ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528,
- -0.113749750828501, -0.0540798505887575, -0.719018251689331,
- -1.02002920513898, -0.133167075802704, -0.228504275273568,
- -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392,
- -0.949501763500117, -1.09911307059764, -0.234373142554013,
- -0.0610136281766905, -0.614831158775111, -0.875588846521461,
- -0.267096146835881, 0.243882464912086, -0.525573959766865, 0.38889466127034,
- -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
- 0.0881535457958548, 1.21771079504409))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538,
- 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
- 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
- dim = 4:3))
- testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
- -0.106753094432726, 1.52394871772745))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = 7.85857128981734, sumY = 13.5810460445817, sumZ = 3.15823002771053,
- sumMu = 9.93005749962466))
-
- # single latent variable (n_clusters = 1): Z is a one-column matrix, and the
- # proxy block adds bulk noise to the raw vector Z.
- set.seed(23478)
- ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2,
- snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-0.00161764234876749,
- -0.557794858227907, -0.827386446973581, -0.460377784885637, -2.67619233265038,
- 0.671711827459298, 1.65236925524076, -0.600115109545631, -0.280741265470752,
- -1.67026187144442, -0.0473803806232191, 0.0826508004462609, 0.170200984778884,
- 0.976190994120857, -0.499749723868518, -0.474295388720649, -1.17346153974724,
- -0.574655697546479, -0.120791507647279, -0.567678976454219, -1.3596277359555,
- -0.0619416164679036, 0.538496824968004, 0.51591446765952), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(-0.558336409902388, -2.73369761842788,
- -0.884087327686163, -3.17343267752372))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538),
- dim = c(4L, 1L)))
- testthat::expect_equal(ret$mu[1:4], c(0.195781398124046, -1.51661095607912,
- -0.722190912632797, -2.90119777610212))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = -5.88971766152033, sumY = -7.36101068003228, sumZ = -2.4782435456402,
- sumMu = -5.08843939501818))
-})
-
-testthat::test_that("genClusteredDataWeighted output is byte-stable (characterization snapshot, #16)", {
- set.seed(23478)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528,
- -0.113749750828501, -0.0540798505887575, -0.719018251689331,
- -1.02002920513898, -0.133167075802704, -0.228504275273568,
- -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392,
- -0.949501763500117, -0.748805376677026, 0.925796953277494, -0.766705940388196,
- -0.348877774329742, 1.96822115764394, 0.528035720534176, 2.93942827641455,
- 0.736079254765787, 0.38889466127034, -0.196999108158916, -0.548580993298435,
- 1.29708342622908), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
- 0.0881535457958548, 1.21771079504409))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538,
- 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
- 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
- dim = 4:3))
- testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
- -0.106753094432726, 1.52394871772745))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = 15.3829830134111, sumY = 13.5810460445817, sumZ = 3.15823002771053,
- sumMu = 9.93005749962466))
-
- # single latent variable (n_clusters = 1)
- set.seed(23478)
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.07114417787482,
- -0.368013007285506, 0.014438919713251, -0.845503147886515, -1.23739163512048,
- -0.174811089926991, -0.0829364724064908, -0.479069797377207, -1.12138274604786,
- -0.402828108682171, 0.104291325515473, -0.844159398768831, 0.352430473911601,
- -1.4960796572646, -1.23544829374631, 0.148162490964714, -1.03021388828778,
- 0.576416731940481, -0.513340292522171, -1.14008022670496, 0.402628944106856,
- -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795,
- 0.513991031913566, -2.95972727928473))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538),
- dim = c(4L, 1L)))
- testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239,
- 0.564187042362111, -2.19774596140566))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = -24.0234160115409, sumY = -10.2198990332918, sumZ = 0.586596841562748,
- sumMu = -5.15679097838167))
-})
-
-testthat::test_that("genClusteredDataWeightedRandom output is byte-stable (characterization snapshot, #16)", {
- set.seed(23478)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.1897691657824,
- -0.00982041549935259, 0.665172439447775, -0.756543570417209, 1.15949678203449,
- -2.91344510959381, 0.491240389956153, -1.30476423524191, -0.485131132932798,
- 0.707045727376943, 3.2222522503854, -3.27350445562509, -1.85428176680484,
- -0.0656090373877866, -0.551130785327929, -1.90090513408521, -1.29616909361208,
- -0.144918159176611, 0.544180897409365, -0.50148178532334, 0.627200376817289,
- 0.171599744439457, -1.07507438640901, 1.5693792481444), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
- 0.0881535457958548, 1.21771079504409))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538,
- 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
- 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
- dim = 4:3))
- testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
- -0.106753094432726, 1.52394871772745))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = 3.23025166163967, sumY = 13.5810460445817, sumZ = 3.15823002771053,
- sumMu = 9.93005749962466))
-
- # single latent variable (n_clusters = 1)
- set.seed(23478)
- ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2,
- cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5,
- beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.36526166060881,
- 0.586409931283558, 1.2227469255493, -2.17655371414979, 0.326418806550987,
- -1.09714072579561, 1.4239012653582, -0.760011975131564, -0.227256340192126,
- -1.84845832529723, 0.184388770399019, -0.394752299747441, -1.47062212216842,
- -0.12215942773548, -0.0749451055463801, -0.842364831584477, -1.41223753691949,
- -1.68487949598676, 0.247717311839652, -1.86068883953814, 0.402628944106856,
- -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L)))
- testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795,
- 0.513991031913566, -2.95972727928473))
- testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
- -0.338373896594486, 0.00224652036037424, -0.638671932314538),
- dim = c(4L, 1L)))
- testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239,
- 0.564187042362111, -2.19774596140566))
- testthat::expect_equal(
- c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
- c(sumX = -28.8273582900822, sumY = -10.2198990332918, sumZ = 0.586596841562748,
- sumMu = -5.15679097838167))
-})
+# Characterization snapshots: pin the EXACT generated values (X / y / Z / mu)
+# under fixed seeds so the #16 consolidation of the genClusteredData* functions
+# and their validators is provably behavior-preserving. The existing "... works"
+# tests only check distributional properties (correlations, ranges), NOT the
+# exact RNG draw order, which differs across the three generators (bulk vs
+# per-column vs random-per-column). Regenerate ONLY if the data-generating
+# algorithm intentionally changes.
+
+testthat::test_that("genClusteredData output is byte-stable (characterization snapshot, #16)", {
+ set.seed(23478)
+ ret <- genClusteredData(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho=.99, beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528,
+ -0.113749750828501, -0.0540798505887575, -0.719018251689331,
+ -1.02002920513898, -0.133167075802704, -0.228504275273568,
+ -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392,
+ -0.949501763500117, -1.09911307059764, -0.234373142554013,
+ -0.0610136281766905, -0.614831158775111, -0.875588846521461,
+ -0.267096146835881, 0.243882464912086, -0.525573959766865, 0.38889466127034,
+ -0.196999108158916, -0.548580993298435, 1.29708342622908), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
+ 0.0881535457958548, 1.21771079504409))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538,
+ 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
+ 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
+ dim = 4:3))
+ testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
+ -0.106753094432726, 1.52394871772745))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = 7.85857128981734, sumY = 13.5810460445817, sumZ = 3.15823002771053,
+ sumMu = 9.93005749962466))
+
+ # single latent variable (n_clusters = 1): Z is a one-column matrix, and the
+ # proxy block adds bulk noise to the raw vector Z.
+ set.seed(23478)
+ ret <- genClusteredData(n=5, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=1, sig_clusters=1, rho=.8, beta_latent=1.5, beta_unclustered=-2,
+ snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-0.00161764234876749,
+ -0.557794858227907, -0.827386446973581, -0.460377784885637, -2.67619233265038,
+ 0.671711827459298, 1.65236925524076, -0.600115109545631, -0.280741265470752,
+ -1.67026187144442, -0.0473803806232191, 0.0826508004462609, 0.170200984778884,
+ 0.976190994120857, -0.499749723868518, -0.474295388720649, -1.17346153974724,
+ -0.574655697546479, -0.120791507647279, -0.567678976454219, -1.3596277359555,
+ -0.0619416164679036, 0.538496824968004, 0.51591446765952), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(-0.558336409902388, -2.73369761842788,
+ -0.884087327686163, -3.17343267752372))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538),
+ dim = c(4L, 1L)))
+ testthat::expect_equal(ret$mu[1:4], c(0.195781398124046, -1.51661095607912,
+ -0.722190912632797, -2.90119777610212))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = -5.88971766152033, sumY = -7.36101068003228, sumZ = -2.4782435456402,
+ sumMu = -5.08843939501818))
+})
+
+testthat::test_that("genClusteredDataWeighted output is byte-stable (characterization snapshot, #16)", {
+ set.seed(23478)
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.02641989570528,
+ -0.113749750828501, -0.0540798505887575, -0.719018251689331,
+ -1.02002920513898, -0.133167075802704, -0.228504275273568,
+ -0.594853445315136, -1.3743321671407, -0.691923420713347, -0.11653157345392,
+ -0.949501763500117, -0.748805376677026, 0.925796953277494, -0.766705940388196,
+ -0.348877774329742, 1.96822115764394, 0.528035720534176, 2.93942827641455,
+ 0.736079254765787, 0.38889466127034, -0.196999108158916, -0.548580993298435,
+ 1.29708342622908), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
+ 0.0881535457958548, 1.21771079504409))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538,
+ 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
+ 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
+ dim = 4:3))
+ testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
+ -0.106753094432726, 1.52394871772745))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = 15.3829830134111, sumY = 13.5810460445817, sumZ = 3.15823002771053,
+ sumMu = 9.93005749962466))
+
+ # single latent variable (n_clusters = 1)
+ set.seed(23478)
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=1, sig_clusters=1, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.07114417787482,
+ -0.368013007285506, 0.014438919713251, -0.845503147886515, -1.23739163512048,
+ -0.174811089926991, -0.0829364724064908, -0.479069797377207, -1.12138274604786,
+ -0.402828108682171, 0.104291325515473, -0.844159398768831, 0.352430473911601,
+ -1.4960796572646, -1.23544829374631, 0.148162490964714, -1.03021388828778,
+ 0.576416731940481, -0.513340292522171, -1.14008022670496, 0.402628944106856,
+ -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795,
+ 0.513991031913566, -2.95972727928473))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538),
+ dim = c(4L, 1L)))
+ testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239,
+ 0.564187042362111, -2.19774596140566))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = -24.0234160115409, sumY = -10.2198990332918, sumZ = 0.586596841562748,
+ sumMu = -5.15679097838167))
+})
+
+testthat::test_that("genClusteredDataWeightedRandom output is byte-stable (characterization snapshot, #16)", {
+ set.seed(23478)
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.1897691657824,
+ -0.00982041549935259, 0.665172439447775, -0.756543570417209, 1.15949678203449,
+ -2.91344510959381, 0.491240389956153, -1.30476423524191, -0.485131132932798,
+ 0.707045727376943, 3.2222522503854, -3.27350445562509, -1.85428176680484,
+ -0.0656090373877866, -0.551130785327929, -1.90090513408521, -1.29616909361208,
+ -0.144918159176611, 0.544180897409365, -0.50148178532334, 0.627200376817289,
+ 0.171599744439457, -1.07507438640901, 1.5693792481444), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(1.78818155412284, 2.55825580753328,
+ 0.0881535457958548, 1.21771079504409))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538,
+ 0.402628944106856, -0.0568963388614887, -0.533358544824988, 1.23055042537552,
+ 0.495888208134907, 2.19477907424054, 0.357725198858587, -0.863633909554439),
+ dim = 4:3))
+ testthat::expect_equal(ret$mu[1:4], c(1.12211695300006, 3.29507281236772,
+ -0.106753094432726, 1.52394871772745))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = 3.23025166163967, sumY = 13.5810460445817, sumZ = 3.15823002771053,
+ sumMu = 9.93005749962466))
+
+ # single latent variable (n_clusters = 1)
+ set.seed(23478)
+ ret <- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2,
+ cluster_size=5, n_clusters=1, sig_clusters=1, rho_high=1, rho_low=.5,
+ beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_equal(ret$X[1:4, 1:6], structure(c(-1.36526166060881,
+ 0.586409931283558, 1.2227469255493, -2.17655371414979, 0.326418806550987,
+ -1.09714072579561, 1.4239012653582, -0.760011975131564, -0.227256340192126,
+ -1.84845832529723, 0.184388770399019, -0.394752299747441, -1.47062212216842,
+ -0.12215942773548, -0.0749451055463801, -0.842364831584477, -1.41223753691949,
+ -1.68487949598676, 0.247717311839652, -1.86068883953814, 0.402628944106856,
+ -0.0568963388614887, -0.533358544824988, 1.23055042537552), dim = c(4L, 6L)))
+ testthat::expect_equal(ret$y[1:4], c(-3.91149964768012, -4.73964429926795,
+ 0.513991031913566, -2.95972727928473))
+ testthat::expect_equal(ret$Z[1:4, , drop = FALSE], structure(c(-1.13051559031852,
+ -0.338373896594486, 0.00224652036037424, -0.638671932314538),
+ dim = c(4L, 1L)))
+ testthat::expect_equal(ret$mu[1:4], c(-3.20232310305676, -3.49765450037239,
+ 0.564187042362111, -2.19774596140566))
+ testthat::expect_equal(
+ c(sumX=sum(ret$X), sumY=sum(ret$y), sumZ=sum(ret$Z), sumMu=sum(ret$mu)),
+ c(sumX = -28.8273582900822, sumY = -10.2198990332918, sumZ = 0.586596841562748,
+ sumMu = -5.15679097838167))
+})
## Test passed with 10 successes.
## Test passed with 10 successes.
## Test passed with 10 successes.
@@ -1008,579 +1008,579 @@
as genClusteredData() (#35): a non-numeric snr / sigma_eps_sq is rejected
up front rather than silently passing the old lean check and failing later
inside genZmuY().
-testthat::test_that("genClusteredData* reject n < 2 and non-integer cluster_size / p (#70)", {
- ok <- list(n = 10, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1,
- sig_clusters = 1, sigma_eps_sq = 1)
- testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(n = 1L))),
- "n >= 2", fixed = TRUE)
- testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(cluster_size = 2.5))),
- "cluster_size == round(cluster_size)", fixed = TRUE)
- testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(p = 8.5))),
- "p == round(p)", fixed = TRUE)
- # n = 2 is the tight boundary -- it must still WORK (locks the threshold
- # against a future "n >= 3" / "> 2" regression).
- res2 <- do.call(genClusteredData, utils::modifyList(ok, list(n = 2L)))
- testthat::expect_equal(nrow(res2$X), 2L)
- # The shared genZmuY n-guard and the shared Pre cluster_size check cover the
- # weighted generators too:
- wok <- list(n = 1L, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1,
- n_strong_cluster_vars = 2, sig_clusters = 1, rho_high = 0.8,
- rho_low = 0.2, sigma_eps_sq = 1)
- testthat::expect_error(do.call(genClusteredDataWeighted, wok),
- "n >= 2", fixed = TRUE)
- testthat::expect_error(
- do.call(genClusteredDataWeighted, utils::modifyList(wok, list(n = 10L, cluster_size = 2.5))),
- "cluster_size == round(cluster_size)", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted/Random validate snr/sigma_eps_sq type (#35)", {
- # Newly rejected (these previously slipped past the weighted validators' lean
- # checks and only failed later, cryptically, inside genZmuY).
- testthat::expect_error(
- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1",
- sigma_eps_sq=NA),
- "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE)
- testthat::expect_error(
- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA,
- sigma_eps_sq="0.5"),
- "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
- beta_unclustered=-2, snr="1", sigma_eps_sq=NA),
- "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"),
- "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE)
-
- # Range checks (snr > 0, sigma_eps_sq >= 0) are unchanged by #35.
- testthat::expect_error(
- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=-.2,
- sigma_eps_sq=NA),
- "snr > 0 is not TRUE", fixed=TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
- beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3),
- "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
-
- # A valid scalar numeric snr / sigma_eps_sq is still accepted.
- ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
- n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
- rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
-})
-
-testthat::test_that("genClusteredData rejects rho > 1 up front (#162)", {
- # The documented upper bound is now enforced by the up-front checker, so the
- # message names the user's argument rho instead of surfacing from deep
- # inside getNoiseVar(). Split one case per block: under testthat edition 3,
- # which this package declares, expect_error() re-raises on a message mismatch
- # and aborts the rest of its block, so bundling would hide the red side of
- # every case after the first. The edition is load-bearing -- at edition 2 the
- # block continues instead, so measuring this outside a package context (where
- # edition 2 is the default) measures the wrong semantics.
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = 1.2, sigma_eps_sq = 1),
- "rho <= 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredData rejects a non-numeric rho (#162)", {
- # Without the type check this slipped through: stopifnot("0.8" > 0) is TRUE,
- # because R compares character to numeric as strings. It then failed later,
- # inside getNoiseVar().
- #
- # The message alone stopped being a sufficient guard when #181 renamed
- # getNoiseVar()'s formal cor -> rho: the validator's check and getNoiseVar()'s
- # are now the SAME line, so both raise
- # is.numeric(rho) | is.integer(rho) is not TRUE
- # and the string can no longer tell "rejected up front" from "died late
- # inside getNoiseVar()". Measured: deleting the validator's type check leaves
- # this block green if it pins only the message, because "0.8" > 0 and
- # "0.8" <= 1 are both TRUE (string comparison), so a character rho reaches
- # genZmuY(), draws from the stream, and dies in getNoiseVar() raising the
- # identical condition.
- #
- # The RNG state distinguishes the two frames no matter what the message says,
- # and early rejection is what #162 was actually about -- so assert it here
- # rather than relying on a string that two independent guards now share.
- set.seed(20260817)
- seed_before <- .Random.seed
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = "0.8", sigma_eps_sq = 1),
- "is.numeric(rho) | is.integer(rho) is not TRUE", fixed = TRUE)
- testthat::expect_identical(.Random.seed, seed_before)
-})
-
-testthat::test_that("genClusteredData rejects a length > 1 rho (#162)", {
- # Previously NO error at all. A length-2 rho produced a length-2 noise
- # variance, which rnorm() recycles elementwise over its flat draw, so the
- # noise sd alternated row by row WITHIN every proxy column. Measured on the
- # pre-fix code with rho = c(0.9, 0.5) and seed 1, the eight proxy
- # correlations were 0.58 0.25 0.55 0.52 0.47 0.60 0.58 0.47 -- every one
- # corrupted, none at either requested value.
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = c(0.9, 0.5), sigma_eps_sq = 1),
- "length(rho) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredData rejects a missing rho (#162)", {
- # Previously reported the misleading "rho > 0 is not TRUE".
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = NA_real_, sigma_eps_sq = 1),
- "!is.na(rho) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredData rejects rho before drawing any random numbers (#162)", {
- # "Up front" is the point of the issue, so assert it directly: a rejected
- # rho must not have advanced the RNG. Before the fix, rho = 1.2 died inside
- # getNoiseVar() only after genZmuY() had already drawn from the stream.
- # The expect_error() below deliberately asserts no message: this block's
- # subject is the RNG state, and the message for this exact input is already
- # pinned by the "rejects rho > 1 up front" block above.
- set.seed(20260815)
- seed_before <- .Random.seed
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = 1.2, sigma_eps_sq = 1))
- testthat::expect_identical(.Random.seed, seed_before)
-})
-
-testthat::test_that("genClusteredData keeps rejecting rho <= 0 (#162)", {
- # The lower bound is unchanged; this locks its message against the reorder.
- testthat::expect_error(
- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = 0, sigma_eps_sq = 1),
- "rho > 0 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredData accepts rho = 1, the tight upper boundary (#162)", {
- # rho = 1 must still WORK, so the new bound is <= and not <. getNoiseVar(1)
- # is exactly 0, so every proxy is a noiseless copy of its latent column --
- # a seed-independent identity, and a far stronger lock than dim(X), which
- # would hold at any rho.
- set.seed(20260815)
- res <- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
- n_clusters = 2, rho = 1, sigma_eps_sq = 1)
- testthat::expect_equal(dim(res$X), c(50L, 13L))
- Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
- testthat::expect_equal(res$X[, 1:8], Z_expanded)
-})
-
-testthat::test_that("genClusteredDataWeighted enforces the documented n_strong_cluster_vars range (#162, refs #164)", {
- # Both bounds already errored; these are the negative tests that were
- # missing (#164) for the constraint now documented on the help page.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 0, n_clusters = 2,
- sigma_eps_sq = 1),
- "n_strong_cluster_vars >= 1 is not TRUE", fixed = TRUE)
-
- # An all-strong cluster is a natural request and is rejected: the second
- # proxy loop would run (cluster_size + 1):cluster_size, which descends
- # rather than being empty, so it writes the NEXT cluster's first proxy
- # column -- and on the final cluster that index is past ncol(proxy_mat), so
- # the unguarded loop dies with "subscript out of bounds". The guard trades
- # that obscure indexing error for one naming the argument.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 4, n_clusters = 2,
- sigma_eps_sq = 1),
- "n_strong_cluster_vars < cluster_size is not TRUE", fixed = TRUE)
-
- # Interior values are accepted AND split the columns as documented. With
- # rho_high = 1 the strong proxies are noiseless copies of their latent
- # column and the weak ones are not, which locks the split itself rather
- # than just the shape of X. n = 500 rather than 50 so that the weak-proxy
- # correlation check below discriminates: measured at n = 50, a rho_low = 0.5
- # proxy's sample correlation was 0.33 while pure independent noise reached
- # 0.48 over 200 draws, so any threshold there would be vacuous. At n = 500
- # the weak proxies measure ~0.53 and pure noise tops out at 0.16.
- set.seed(20260815)
- res <- genClusteredDataWeighted(n = 500, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 1, rho_low = 0.5, sigma_eps_sq = 1)
- Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
- strong <- c(1:3, 5:7)
- weak <- c(4L, 8L)
- testthat::expect_equal(res$X[, strong], Z_expanded[, strong])
- testthat::expect_false(any(res$X[, weak] == Z_expanded[, weak]))
- # The weak proxies must still carry the latent signal at roughly rho_low, and
- # this is a two-sided band rather than a floor on purpose. A one-sided
- # "> 0.3" passes a bug that hands the weak proxies rho_high instead
- # (measured: weak_cor 0.951, 0.956) -- which is precisely the strong/weak
- # split failure this block exists to catch, so a floor would be blind to it.
- # At n = 500 the sampling sd of the correlation is ~0.034 and the seed is
- # fixed, so a 0.1 band is ~3 sd wide: the correct values sit 0.028 and 0.040
- # away from rho_low, while pure noise (~0) and a rho_high mix-up (~0.95) both
- # fall well outside.
- weak_cor <- vapply(weak,
- function(j) stats::cor(res$X[, j], Z_expanded[, j]), numeric(1))
- testthat::expect_true(all(abs(weak_cor - 0.5) < 0.1))
- testthat::expect_false(anyNA(res$X))
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_high (#181)", {
- # Previously slipped past all four range checks and died inside
- # getNoiseVar(), naming that helper's formal rather than the user's
- # argument, and only after the RNG had already advanced. The type check has
- # to precede every range check: stopifnot("0.9" >= 0.5) is TRUE, because R
- # coerces the number to a string and compares as strings rather than
- # erroring. ("10" >= 9 is FALSE, which is the giveaway that it is a string
- # comparison and not a numeric one.)
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1),
- "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_high (#181)", {
- # The same hole with a different landing place: this generator reached
- # runif(n = 1, min = rho_low, max = rho_high) and reported the opaque
- # "invalid arguments", again only after advancing the RNG.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = "0.8", rho_low = 0.5,
- sigma_eps_sq = 1),
- "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_low (#181)", {
- # As for rho_high: the string comparison rho_high >= rho_low is TRUE for
- # "0.2", so the old range checks passed it straight through to getNoiseVar().
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.9, rho_low = "0.2", sigma_eps_sq = 1),
- "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_low (#181)", {
- # Previously reported runif()'s "invalid arguments", after advancing the RNG.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = "0.2",
- sigma_eps_sq = 1),
- "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a logical rho_high (#181)", {
- # A logical argument is the same type hole, but the two generators failed
- # very differently. genClusteredDataWeighted() errored naming getNoiseVar()'s
- # formal, while genClusteredDataWeightedRandom() accepted TRUE outright (the
- # block below) -- so the pair belongs to the silent-wrong-answer class, not
- # merely the bad-message class.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1),
- "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_high (#181)", {
- # Previously NO error at all: runif(1, 0.5, TRUE) coerces TRUE to 1, so the
- # call returned a data set silently generated at rho_high = 1 instead of
- # rejecting an argument that is not a correlation.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = TRUE, rho_low = 0.5,
- sigma_eps_sq = 1),
- "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a logical rho_low (#181)", {
- # rho_high = 1 is deliberate. This input errors at either setting, but at
- # rho_high = 1 the pre-change code advanced the RNG before dying inside
- # getNoiseVar(), whereas at rho_high = 0.9 the ordering check caught it with
- # the stream untouched -- blaming the ordering for what is a type error. The
- # rho_high = 1 variant is the worse defect, so it is the one to lock.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1),
- "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_low (#181)", {
- # rho_high = 1 is load-bearing here for a different reason: it is this
- # generator's DEFAULT, and the only setting under which rho_low = TRUE was
- # accepted at all -- runif(1, TRUE, 1) coerces TRUE to 1, so the call
- # silently returned data. A silent wrong answer on the default path.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = TRUE,
- sigma_eps_sq = 1),
- "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_high (#181)", {
- # Previously NO error at all -- the silent-wrong-answer case this issue was
- # filed about. genClusteredDataWeighted() calls getNoiseVar() once per
- # argument and then draws per column, rnorm(n, sd = sqrt(noise_var_high)),
- # so a length-2 argument makes sd length 2 and rnorm() recycles it
- # elementwise DOWN the column: the noise sd alternates row by row within
- # every column that argument governs. The columns governed by the other,
- # scalar argument keep exactly the correlation they asked for.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_high (#181)", {
- # Previously NO error either, but by a different route: this generator does
- # no recycling at all. The argument reaches
- # runif(n = 1, min = rho_low, max = rho_high), which uses the FIRST element
- # and discards the rest without a word. Truncation, not corruption -- the
- # two generators are not failing the same way.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5,
- sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_low (#181)", {
- # Previously NO error, and this is the case whose corrupted value has a
- # closed form worth recording. Recycling sd = sqrt(c(3, 10.1111))
- # elementwise down a column makes the noise VARIANCE alternate, so the
- # column's marginal noise variance is the mean of the two and BOTH weak
- # columns land on
- # 1/sqrt(1 + mean(c(getNoiseVar(0.5), getNoiseVar(0.3)))) = 1/sqrt(1 +
- # 6.5556) = 0.3638 -- neither requested value, and identical for the two of
- # them. That is the population value, not a sample estimate: quoting a
- # measured pair would imply a between-column difference that does not exist,
- # and every seed produces a different pair.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1),
- "length(rho_low) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_low (#181)", {
- # Previously NO error: the same first-element truncation as for rho_high.
- # Measured on the pre-change tree at a fixed seed, the returned X was
- # identical() to the rho_low = 0.5 run and not to the rho_low = 0.3 run.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3),
- sigma_eps_sq = 1),
- "length(rho_low) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a zero-length rho_high (#181)", {
- # All four range checks are STRUCTURALLY INERT against a zero-length
- # argument: numeric(0) <= 1 is logical(0), and all(logical(0)) is TRUE, so
- # stopifnot() does not error. The call therefore reached getNoiseVar() and
- # reported that helper's formal. NULL is in the same family but is NOT
- # interchangeable -- is.numeric(NULL) is FALSE, so NULL is caught by the
- # TYPE check and never reaches the length check. numeric(0) is the input
- # that exercises the length check at its zero end.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a zero-length rho_high (#181)", {
- # The same inert range checks. Here the call got as far as runif(), which
- # returned NA with a "NAs produced" warning, and the failure then surfaced
- # from inside getNoiseVar() rather than naming rho_high.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5,
- sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a missing rho_high (#181)", {
- # Previously reported the misleading "rho_high <= 1 is not TRUE" -- a range
- # bound blamed for a missingness problem, which sends the user off checking
- # a value that is not the issue.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1),
- "!is.na(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_high (#181)", {
- # Same misleading "rho_high <= 1 is not TRUE" before the change.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5,
- sigma_eps_sq = 1),
- "!is.na(rho_high) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted rejects a missing rho_low (#181)", {
- # Previously reported "rho_low > 0 is not TRUE" -- the lower bound this
- # time rather than the upper one, but the identical class: a range bound
- # blamed for missingness.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.9, rho_low = NA_real_, sigma_eps_sq = 1),
- "!is.na(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_low (#181)", {
- # Same misleading "rho_low > 0 is not TRUE" before the change.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = NA_real_,
- sigma_eps_sq = 1),
- "!is.na(rho_low) is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted checks rho_high's length before its missingness (#181)", {
- # This block exists for the FINE ordering -- length before NA -- which every
- # other block here is blind to. Only an input that is simultaneously length
- # > 1 AND contains NA can tell the two orderings apart: measured, the
- # shipped order reports the length violation below, while checking !is.na()
- # first reports the confusing plural "!is.na(rho_high) are not all TRUE",
- # because !is.na() is vectorized. Before the change this input reported
- # neither, dying in the range checks with "rho_high <= 1 are not all TRUE".
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeightedRandom checks rho_high's length before its missingness (#181)", {
- # The fine-ordering lock for the second generator; see the block above for
- # why an input that is both length > 1 and NA-containing is the only one
- # that distinguishes the two orderings.
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5,
- sigma_eps_sq = 1),
- "length(rho_high) == 1 is not TRUE", fixed = TRUE)
-})
-
-testthat::test_that("genClusteredDataWeighted* reject rho_high/rho_low before drawing any random numbers (#181)", {
- # "Up front" is the point of the issue, so assert it directly. A length-2
- # argument is the right probe: it advanced the RNG in both generators before
- # the change, whereas an NA argument was already caught by a range check
- # with the stream untouched and so would prove nothing.
- # This block stays BUNDLED across both generators, unlike every block above.
- # Its expect_error() calls carry no message argument, so they cannot
- # mismatch, so they cannot re-raise and abort the block under testthat
- # edition 3 -- all four assertions are reached even when all four fail.
- set.seed(20260817)
- seed_before <- .Random.seed
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1))
- testthat::expect_identical(.Random.seed, seed_before)
-
- set.seed(20260817)
- seed_before <- .Random.seed
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3),
- sigma_eps_sq = 1))
- testthat::expect_identical(.Random.seed, seed_before)
-})
-
-testthat::test_that("genClusteredDataWeighted* still accept the boundary rho values (#181)", {
- # rho = 1 must still WORK, so the bound is <= and not <. getNoiseVar(1) is
- # exactly 0, so every proxy is a noiseless copy of its latent column -- a
- # seed-independent identity, and a far stronger lock than dim(X), which
- # would hold at any rho. Passing rho_high = rho_low = 1 hits the upper
- # boundary and the rho_high == rho_low boundary at once.
- set.seed(20260817)
- res <- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 1, rho_low = 1, sigma_eps_sq = 1)
- Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
- testthat::expect_equal(res$X[, 1:8], Z_expanded)
-
- # rho_high is OMITTED here, so its default of 1 applies: one call covering
- # the upper boundary, the rho_high == rho_low boundary, and the default path
- # the issue's closing note asks about. runif(1, 1, 1) is exactly 1, so the
- # same noiseless identity holds for this generator too.
- set.seed(20260817)
- res_rand <- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_low = 1, sigma_eps_sq = 1)
- Z_expanded_rand <- as.matrix(res_rand$Z)[, rep(1:2, each = 4), drop = FALSE]
- testthat::expect_equal(res_rand$X[, 1:8], Z_expanded_rand)
-})
-
-testthat::test_that("genClusteredDataWeighted* keep their existing rho range messages (#181)", {
- # What this locks, precisely: the four range checks survive the move into
- # checkRhoHighLow() with their exact messages. It is GREEN on the pre-change
- # tree by design -- it locks behavior that must not change, so its power
- # comes from mutation rather than from a red side. It is the only block in
- # this set that notices if one of the four checks is dropped.
- #
- # It does NOT lock their order, and two reorderings are invisible to it.
- # Swapping > 0 against <= 1 is invisible because once length-1 and non-NA
- # are established at most one of those two can fail on a scalar, so the
- # orders are observationally identical. Swapping rho_low > 0 against
- # rho_high >= rho_low is invisible for a different reason: measured, all
- # four inputs below report the same message either way, because whichever
- # of the two is violated is still the first of them to fail.
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1),
- "rho_high <= 1 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1),
- "rho_high > 0 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1),
- "rho_low > 0 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
- rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1),
- "rho_high >= rho_low is not TRUE", fixed = TRUE)
-
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 1.2, rho_low = 0.5,
- sigma_eps_sq = 1),
- "rho_high <= 1 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 0, rho_low = 0.5,
- sigma_eps_sq = 1),
- "rho_high > 0 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 0.9, rho_low = 0,
- sigma_eps_sq = 1),
- "rho_low > 0 is not TRUE", fixed = TRUE)
- testthat::expect_error(
- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
- cluster_size = 4, n_clusters = 2, rho_high = 0.3, rho_low = 0.5,
- sigma_eps_sq = 1),
- "rho_high >= rho_low is not TRUE", fixed = TRUE)
-})
+testthat::test_that("genClusteredData* reject n < 2 and non-integer cluster_size / p (#70)", {
+ ok <- list(n = 10, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1,
+ sig_clusters = 1, sigma_eps_sq = 1)
+ testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(n = 1L))),
+ "n >= 2", fixed = TRUE)
+ testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(cluster_size = 2.5))),
+ "cluster_size == round(cluster_size)", fixed = TRUE)
+ testthat::expect_error(do.call(genClusteredData, utils::modifyList(ok, list(p = 8.5))),
+ "p == round(p)", fixed = TRUE)
+ # n = 2 is the tight boundary -- it must still WORK (locks the threshold
+ # against a future "n >= 3" / "> 2" regression).
+ res2 <- do.call(genClusteredData, utils::modifyList(ok, list(n = 2L)))
+ testthat::expect_equal(nrow(res2$X), 2L)
+ # The shared genZmuY n-guard and the shared Pre cluster_size check cover the
+ # weighted generators too:
+ wok <- list(n = 1L, p = 8, k_unclustered = 2, cluster_size = 3, n_clusters = 1,
+ n_strong_cluster_vars = 2, sig_clusters = 1, rho_high = 0.8,
+ rho_low = 0.2, sigma_eps_sq = 1)
+ testthat::expect_error(do.call(genClusteredDataWeighted, wok),
+ "n >= 2", fixed = TRUE)
+ testthat::expect_error(
+ do.call(genClusteredDataWeighted, utils::modifyList(wok, list(n = 10L, cluster_size = 2.5))),
+ "cluster_size == round(cluster_size)", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted/Random validate snr/sigma_eps_sq type (#35)", {
+ # Newly rejected (these previously slipped past the weighted validators' lean
+ # checks and only failed later, cryptically, inside genZmuY).
+ testthat::expect_error(
+ genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr="1",
+ sigma_eps_sq=NA),
+ "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE)
+ testthat::expect_error(
+ genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA,
+ sigma_eps_sq="0.5"),
+ "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
+ beta_unclustered=-2, snr="1", sigma_eps_sq=NA),
+ "is.numeric(snr) | is.integer(snr) is not TRUE", fixed=TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq="0.5"),
+ "is.numeric(sigma_eps_sq) | is.integer(sigma_eps_sq) is not TRUE", fixed=TRUE)
+
+ # Range checks (snr > 0, sigma_eps_sq >= 0) are unchanged by #35.
+ testthat::expect_error(
+ genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=-.2,
+ sigma_eps_sq=NA),
+ "snr > 0 is not TRUE", fixed=TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_clusters=3, sig_clusters=2, rho_high=1, rho_low=.5, beta_latent=1.5,
+ beta_unclustered=-2, snr=NA, sigma_eps_sq=-.3),
+ "sigma_eps_sq >= 0 is not TRUE", fixed=TRUE)
+
+ # A valid scalar numeric snr / sigma_eps_sq is still accepted.
+ ret <- genClusteredDataWeighted(n=25, p=19, k_unclustered=2, cluster_size=5,
+ n_strong_cluster_vars=3, n_clusters=3, sig_clusters=2, rho_high=.99,
+ rho_low=.5, beta_latent=1.5, beta_unclustered=-2, snr=NA, sigma_eps_sq=.5)
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+})
+
+testthat::test_that("genClusteredData rejects rho > 1 up front (#162)", {
+ # The documented upper bound is now enforced by the up-front checker, so the
+ # message names the user's argument rho instead of surfacing from deep
+ # inside getNoiseVar(). Split one case per block: under testthat edition 3,
+ # which this package declares, expect_error() re-raises on a message mismatch
+ # and aborts the rest of its block, so bundling would hide the red side of
+ # every case after the first. The edition is load-bearing -- at edition 2 the
+ # block continues instead, so measuring this outside a package context (where
+ # edition 2 is the default) measures the wrong semantics.
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = 1.2, sigma_eps_sq = 1),
+ "rho <= 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredData rejects a non-numeric rho (#162)", {
+ # Without the type check this slipped through: stopifnot("0.8" > 0) is TRUE,
+ # because R compares character to numeric as strings. It then failed later,
+ # inside getNoiseVar().
+ #
+ # The message alone stopped being a sufficient guard when #181 renamed
+ # getNoiseVar()'s formal cor -> rho: the validator's check and getNoiseVar()'s
+ # are now the SAME line, so both raise
+ # is.numeric(rho) | is.integer(rho) is not TRUE
+ # and the string can no longer tell "rejected up front" from "died late
+ # inside getNoiseVar()". Measured: deleting the validator's type check leaves
+ # this block green if it pins only the message, because "0.8" > 0 and
+ # "0.8" <= 1 are both TRUE (string comparison), so a character rho reaches
+ # genZmuY(), draws from the stream, and dies in getNoiseVar() raising the
+ # identical condition.
+ #
+ # The RNG state distinguishes the two frames no matter what the message says,
+ # and early rejection is what #162 was actually about -- so assert it here
+ # rather than relying on a string that two independent guards now share.
+ set.seed(20260817)
+ seed_before <- .Random.seed
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = "0.8", sigma_eps_sq = 1),
+ "is.numeric(rho) | is.integer(rho) is not TRUE", fixed = TRUE)
+ testthat::expect_identical(.Random.seed, seed_before)
+})
+
+testthat::test_that("genClusteredData rejects a length > 1 rho (#162)", {
+ # Previously NO error at all. A length-2 rho produced a length-2 noise
+ # variance, which rnorm() recycles elementwise over its flat draw, so the
+ # noise sd alternated row by row WITHIN every proxy column. Measured on the
+ # pre-fix code with rho = c(0.9, 0.5) and seed 1, the eight proxy
+ # correlations were 0.58 0.25 0.55 0.52 0.47 0.60 0.58 0.47 -- every one
+ # corrupted, none at either requested value.
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = c(0.9, 0.5), sigma_eps_sq = 1),
+ "length(rho) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredData rejects a missing rho (#162)", {
+ # Previously reported the misleading "rho > 0 is not TRUE".
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = NA_real_, sigma_eps_sq = 1),
+ "!is.na(rho) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredData rejects rho before drawing any random numbers (#162)", {
+ # "Up front" is the point of the issue, so assert it directly: a rejected
+ # rho must not have advanced the RNG. Before the fix, rho = 1.2 died inside
+ # getNoiseVar() only after genZmuY() had already drawn from the stream.
+ # The expect_error() below deliberately asserts no message: this block's
+ # subject is the RNG state, and the message for this exact input is already
+ # pinned by the "rejects rho > 1 up front" block above.
+ set.seed(20260815)
+ seed_before <- .Random.seed
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = 1.2, sigma_eps_sq = 1))
+ testthat::expect_identical(.Random.seed, seed_before)
+})
+
+testthat::test_that("genClusteredData keeps rejecting rho <= 0 (#162)", {
+ # The lower bound is unchanged; this locks its message against the reorder.
+ testthat::expect_error(
+ genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = 0, sigma_eps_sq = 1),
+ "rho > 0 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredData accepts rho = 1, the tight upper boundary (#162)", {
+ # rho = 1 must still WORK, so the new bound is <= and not <. getNoiseVar(1)
+ # is exactly 0, so every proxy is a noiseless copy of its latent column --
+ # a seed-independent identity, and a far stronger lock than dim(X), which
+ # would hold at any rho.
+ set.seed(20260815)
+ res <- genClusteredData(n = 50, p = 13, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 2, rho = 1, sigma_eps_sq = 1)
+ testthat::expect_equal(dim(res$X), c(50L, 13L))
+ Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
+ testthat::expect_equal(res$X[, 1:8], Z_expanded)
+})
+
+testthat::test_that("genClusteredDataWeighted enforces the documented n_strong_cluster_vars range (#162, refs #164)", {
+ # Both bounds already errored; these are the negative tests that were
+ # missing (#164) for the constraint now documented on the help page.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 0, n_clusters = 2,
+ sigma_eps_sq = 1),
+ "n_strong_cluster_vars >= 1 is not TRUE", fixed = TRUE)
+
+ # An all-strong cluster is a natural request and is rejected: the second
+ # proxy loop would run (cluster_size + 1):cluster_size, which descends
+ # rather than being empty, so it writes the NEXT cluster's first proxy
+ # column -- and on the final cluster that index is past ncol(proxy_mat), so
+ # the unguarded loop dies with "subscript out of bounds". The guard trades
+ # that obscure indexing error for one naming the argument.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 4, n_clusters = 2,
+ sigma_eps_sq = 1),
+ "n_strong_cluster_vars < cluster_size is not TRUE", fixed = TRUE)
+
+ # Interior values are accepted AND split the columns as documented. With
+ # rho_high = 1 the strong proxies are noiseless copies of their latent
+ # column and the weak ones are not, which locks the split itself rather
+ # than just the shape of X. n = 500 rather than 50 so that the weak-proxy
+ # correlation check below discriminates: measured at n = 50, a rho_low = 0.5
+ # proxy's sample correlation was 0.33 while pure independent noise reached
+ # 0.48 over 200 draws, so any threshold there would be vacuous. At n = 500
+ # the weak proxies measure ~0.53 and pure noise tops out at 0.16.
+ set.seed(20260815)
+ res <- genClusteredDataWeighted(n = 500, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 1, rho_low = 0.5, sigma_eps_sq = 1)
+ Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
+ strong <- c(1:3, 5:7)
+ weak <- c(4L, 8L)
+ testthat::expect_equal(res$X[, strong], Z_expanded[, strong])
+ testthat::expect_false(any(res$X[, weak] == Z_expanded[, weak]))
+ # The weak proxies must still carry the latent signal at roughly rho_low, and
+ # this is a two-sided band rather than a floor on purpose. A one-sided
+ # "> 0.3" passes a bug that hands the weak proxies rho_high instead
+ # (measured: weak_cor 0.951, 0.956) -- which is precisely the strong/weak
+ # split failure this block exists to catch, so a floor would be blind to it.
+ # At n = 500 the sampling sd of the correlation is ~0.034 and the seed is
+ # fixed, so a 0.1 band is ~3 sd wide: the correct values sit 0.028 and 0.040
+ # away from rho_low, while pure noise (~0) and a rho_high mix-up (~0.95) both
+ # fall well outside.
+ weak_cor <- vapply(weak,
+ function(j) stats::cor(res$X[, j], Z_expanded[, j]), numeric(1))
+ testthat::expect_true(all(abs(weak_cor - 0.5) < 0.1))
+ testthat::expect_false(anyNA(res$X))
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_high (#181)", {
+ # Previously slipped past all four range checks and died inside
+ # getNoiseVar(), naming that helper's formal rather than the user's
+ # argument, and only after the RNG had already advanced. The type check has
+ # to precede every range check: stopifnot("0.9" >= 0.5) is TRUE, because R
+ # coerces the number to a string and compares as strings rather than
+ # erroring. ("10" >= 9 is FALSE, which is the giveaway that it is a string
+ # comparison and not a numeric one.)
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = "0.8", rho_low = 0.5, sigma_eps_sq = 1),
+ "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_high (#181)", {
+ # The same hole with a different landing place: this generator reached
+ # runif(n = 1, min = rho_low, max = rho_high) and reported the opaque
+ # "invalid arguments", again only after advancing the RNG.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = "0.8", rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a non-numeric rho_low (#181)", {
+ # As for rho_high: the string comparison rho_high >= rho_low is TRUE for
+ # "0.2", so the old range checks passed it straight through to getNoiseVar().
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.9, rho_low = "0.2", sigma_eps_sq = 1),
+ "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a non-numeric rho_low (#181)", {
+ # Previously reported runif()'s "invalid arguments", after advancing the RNG.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = "0.2",
+ sigma_eps_sq = 1),
+ "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a logical rho_high (#181)", {
+ # A logical argument is the same type hole, but the two generators failed
+ # very differently. genClusteredDataWeighted() errored naming getNoiseVar()'s
+ # formal, while genClusteredDataWeightedRandom() accepted TRUE outright (the
+ # block below) -- so the pair belongs to the silent-wrong-answer class, not
+ # merely the bad-message class.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = TRUE, rho_low = 0.5, sigma_eps_sq = 1),
+ "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_high (#181)", {
+ # Previously NO error at all: runif(1, 0.5, TRUE) coerces TRUE to 1, so the
+ # call returned a data set silently generated at rho_high = 1 instead of
+ # rejecting an argument that is not a correlation.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = TRUE, rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "is.numeric(rho_high) | is.integer(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a logical rho_low (#181)", {
+ # rho_high = 1 is deliberate. This input errors at either setting, but at
+ # rho_high = 1 the pre-change code advanced the RNG before dying inside
+ # getNoiseVar(), whereas at rho_high = 0.9 the ordering check caught it with
+ # the stream untouched -- blaming the ordering for what is a type error. The
+ # rho_high = 1 variant is the worse defect, so it is the one to lock.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 1, rho_low = TRUE, sigma_eps_sq = 1),
+ "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a logical rho_low (#181)", {
+ # rho_high = 1 is load-bearing here for a different reason: it is this
+ # generator's DEFAULT, and the only setting under which rho_low = TRUE was
+ # accepted at all -- runif(1, TRUE, 1) coerces TRUE to 1, so the call
+ # silently returned data. A silent wrong answer on the default path.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = TRUE,
+ sigma_eps_sq = 1),
+ "is.numeric(rho_low) | is.integer(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_high (#181)", {
+ # Previously NO error at all -- the silent-wrong-answer case this issue was
+ # filed about. genClusteredDataWeighted() calls getNoiseVar() once per
+ # argument and then draws per column, rnorm(n, sd = sqrt(noise_var_high)),
+ # so a length-2 argument makes sd length 2 and rnorm() recycles it
+ # elementwise DOWN the column: the noise sd alternates row by row within
+ # every column that argument governs. The columns governed by the other,
+ # scalar argument keep exactly the correlation they asked for.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = c(0.9, 0.8), rho_low = 0.5, sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_high (#181)", {
+ # Previously NO error either, but by a different route: this generator does
+ # no recycling at all. The argument reaches
+ # runif(n = 1, min = rho_low, max = rho_high), which uses the FIRST element
+ # and discards the rest without a word. Truncation, not corruption -- the
+ # two generators are not failing the same way.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = c(0.9, 0.8), rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a length > 1 rho_low (#181)", {
+ # Previously NO error, and this is the case whose corrupted value has a
+ # closed form worth recording. Recycling sd = sqrt(c(3, 10.1111))
+ # elementwise down a column makes the noise VARIANCE alternate, so the
+ # column's marginal noise variance is the mean of the two and BOTH weak
+ # columns land on
+ # 1/sqrt(1 + mean(c(getNoiseVar(0.5), getNoiseVar(0.3)))) = 1/sqrt(1 +
+ # 6.5556) = 0.3638 -- neither requested value, and identical for the two of
+ # them. That is the population value, not a sample estimate: quoting a
+ # measured pair would imply a between-column difference that does not exist,
+ # and every seed produces a different pair.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1),
+ "length(rho_low) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a length > 1 rho_low (#181)", {
+ # Previously NO error: the same first-element truncation as for rho_high.
+ # Measured on the pre-change tree at a fixed seed, the returned X was
+ # identical() to the rho_low = 0.5 run and not to the rho_low = 0.3 run.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3),
+ sigma_eps_sq = 1),
+ "length(rho_low) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a zero-length rho_high (#181)", {
+ # All four range checks are STRUCTURALLY INERT against a zero-length
+ # argument: numeric(0) <= 1 is logical(0), and all(logical(0)) is TRUE, so
+ # stopifnot() does not error. The call therefore reached getNoiseVar() and
+ # reported that helper's formal. NULL is in the same family but is NOT
+ # interchangeable -- is.numeric(NULL) is FALSE, so NULL is caught by the
+ # TYPE check and never reaches the length check. numeric(0) is the input
+ # that exercises the length check at its zero end.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = numeric(0), rho_low = 0.5, sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a zero-length rho_high (#181)", {
+ # The same inert range checks. Here the call got as far as runif(), which
+ # returned NA with a "NAs produced" warning, and the failure then surfaced
+ # from inside getNoiseVar() rather than naming rho_high.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = numeric(0), rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a missing rho_high (#181)", {
+ # Previously reported the misleading "rho_high <= 1 is not TRUE" -- a range
+ # bound blamed for a missingness problem, which sends the user off checking
+ # a value that is not the issue.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = NA_real_, rho_low = 0.5, sigma_eps_sq = 1),
+ "!is.na(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_high (#181)", {
+ # Same misleading "rho_high <= 1 is not TRUE" before the change.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = NA_real_, rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "!is.na(rho_high) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted rejects a missing rho_low (#181)", {
+ # Previously reported "rho_low > 0 is not TRUE" -- the lower bound this
+ # time rather than the upper one, but the identical class: a range bound
+ # blamed for missingness.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.9, rho_low = NA_real_, sigma_eps_sq = 1),
+ "!is.na(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom rejects a missing rho_low (#181)", {
+ # Same misleading "rho_low > 0 is not TRUE" before the change.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = NA_real_,
+ sigma_eps_sq = 1),
+ "!is.na(rho_low) is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted checks rho_high's length before its missingness (#181)", {
+ # This block exists for the FINE ordering -- length before NA -- which every
+ # other block here is blind to. Only an input that is simultaneously length
+ # > 1 AND contains NA can tell the two orderings apart: measured, the
+ # shipped order reports the length violation below, while checking !is.na()
+ # first reports the confusing plural "!is.na(rho_high) are not all TRUE",
+ # because !is.na() is vectorized. Before the change this input reported
+ # neither, dying in the range checks with "rho_high <= 1 are not all TRUE".
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = c(0.9, NA), rho_low = 0.5, sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeightedRandom checks rho_high's length before its missingness (#181)", {
+ # The fine-ordering lock for the second generator; see the block above for
+ # why an input that is both length > 1 and NA-containing is the only one
+ # that distinguishes the two orderings.
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = c(0.9, NA), rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "length(rho_high) == 1 is not TRUE", fixed = TRUE)
+})
+
+testthat::test_that("genClusteredDataWeighted* reject rho_high/rho_low before drawing any random numbers (#181)", {
+ # "Up front" is the point of the issue, so assert it directly. A length-2
+ # argument is the right probe: it advanced the RNG in both generators before
+ # the change, whereas an NA argument was already caught by a range check
+ # with the stream untouched and so would prove nothing.
+ # This block stays BUNDLED across both generators, unlike every block above.
+ # Its expect_error() calls carry no message argument, so they cannot
+ # mismatch, so they cannot re-raise and abort the block under testthat
+ # edition 3 -- all four assertions are reached even when all four fail.
+ set.seed(20260817)
+ seed_before <- .Random.seed
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.9, rho_low = c(0.5, 0.3), sigma_eps_sq = 1))
+ testthat::expect_identical(.Random.seed, seed_before)
+
+ set.seed(20260817)
+ seed_before <- .Random.seed
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1, rho_low = c(0.5, 0.3),
+ sigma_eps_sq = 1))
+ testthat::expect_identical(.Random.seed, seed_before)
+})
+
+testthat::test_that("genClusteredDataWeighted* still accept the boundary rho values (#181)", {
+ # rho = 1 must still WORK, so the bound is <= and not <. getNoiseVar(1) is
+ # exactly 0, so every proxy is a noiseless copy of its latent column -- a
+ # seed-independent identity, and a far stronger lock than dim(X), which
+ # would hold at any rho. Passing rho_high = rho_low = 1 hits the upper
+ # boundary and the rho_high == rho_low boundary at once.
+ set.seed(20260817)
+ res <- genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 1, rho_low = 1, sigma_eps_sq = 1)
+ Z_expanded <- as.matrix(res$Z)[, rep(1:2, each = 4), drop = FALSE]
+ testthat::expect_equal(res$X[, 1:8], Z_expanded)
+
+ # rho_high is OMITTED here, so its default of 1 applies: one call covering
+ # the upper boundary, the rho_high == rho_low boundary, and the default path
+ # the issue's closing note asks about. runif(1, 1, 1) is exactly 1, so the
+ # same noiseless identity holds for this generator too.
+ set.seed(20260817)
+ res_rand <- genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_low = 1, sigma_eps_sq = 1)
+ Z_expanded_rand <- as.matrix(res_rand$Z)[, rep(1:2, each = 4), drop = FALSE]
+ testthat::expect_equal(res_rand$X[, 1:8], Z_expanded_rand)
+})
+
+testthat::test_that("genClusteredDataWeighted* keep their existing rho range messages (#181)", {
+ # What this locks, precisely: the four range checks survive the move into
+ # checkRhoHighLow() with their exact messages. It is GREEN on the pre-change
+ # tree by design -- it locks behavior that must not change, so its power
+ # comes from mutation rather than from a red side. It is the only block in
+ # this set that notices if one of the four checks is dropped.
+ #
+ # It does NOT lock their order, and two reorderings are invisible to it.
+ # Swapping > 0 against <= 1 is invisible because once length-1 and non-NA
+ # are established at most one of those two can fail on a scalar, so the
+ # orders are observationally identical. Swapping rho_low > 0 against
+ # rho_high >= rho_low is invisible for a different reason: measured, all
+ # four inputs below report the same message either way, because whichever
+ # of the two is violated is still the first of them to fail.
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 1.2, rho_low = 0.5, sigma_eps_sq = 1),
+ "rho_high <= 1 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0, rho_low = 0.5, sigma_eps_sq = 1),
+ "rho_high > 0 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.9, rho_low = 0, sigma_eps_sq = 1),
+ "rho_low > 0 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeighted(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_strong_cluster_vars = 3, n_clusters = 2,
+ rho_high = 0.3, rho_low = 0.5, sigma_eps_sq = 1),
+ "rho_high >= rho_low is not TRUE", fixed = TRUE)
+
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 1.2, rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "rho_high <= 1 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 0, rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "rho_high > 0 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 0.9, rho_low = 0,
+ sigma_eps_sq = 1),
+ "rho_low > 0 is not TRUE", fixed = TRUE)
+ testthat::expect_error(
+ genClusteredDataWeightedRandom(n = 50, p = 13, k_unclustered = 2,
+ cluster_size = 4, n_clusters = 2, rho_high = 0.3, rho_low = 0.5,
+ sigma_eps_sq = 1),
+ "rho_high >= rho_low is not TRUE", fixed = TRUE)
+})
## Test passed with 6 successes.
## Test passed with 7 successes.
## Test passed with 1 success.
@@ -1621,877 +1621,877 @@
for y instead of yielding a null latent model. The fix consumes NO randomness
(only deterministic reshaping of mu), so every generator test and
characterization snapshot above stays byte-identical.
-testthat::test_that("genZmuY one-weak-signal config no longer crashes, all 3 generators (#124 bug 1)", {
- # p == n_clusters*cluster_size + 1 leaves exactly ONE weak-signal/noise
- # feature, so other_X had a single column; without drop = FALSE it collapsed
- # to a vector and other_X[, j] errored "incorrect number of dimensions". The
- # pre-check only requires p_orig_feat_mat >= k_unclustered + n_clusters
- # (here 2 >= 2), so it passed straight into the crash.
- ret <- genClusteredData(n = 20, p = 3, k_unclustered = 1, cluster_size = 2,
- n_clusters = 1, snr = 2)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_true(is.matrix(ret$X))
- testthat::expect_equal(ncol(ret$X), 3)
- testthat::expect_equal(nrow(ret$X), 20)
-
- # genClusteredDataWeighted: n_strong_cluster_vars is REQUIRED and its checker
- # enforces >= 1 AND < cluster_size, so with cluster_size = 2 the only valid
- # value is 1.
- retW <- genClusteredDataWeighted(n = 20, p = 3, k_unclustered = 1,
- cluster_size = 2, n_clusters = 1,
- n_strong_cluster_vars = 1, snr = 2)
- testthat::expect_true(is.list(retW))
- testthat::expect_identical(names(retW), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ncol(retW$X), 3)
-
- retR <- genClusteredDataWeightedRandom(n = 20, p = 3, k_unclustered = 1,
- cluster_size = 2, n_clusters = 1,
- snr = 2)
- testthat::expect_true(is.list(retR))
- testthat::expect_identical(names(retR), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ncol(retR$X), 3)
-})
-
-testthat::test_that("genZmuY sig_clusters == 0 yields a null latent model (#124 bug 2)", {
- # The zero-beta case MUST bypass genClusteredData: its validator rejects
- # beta_unclustered == 0 / beta_latent == 0, so exercise the internal helper
- # directly. sig_clusters == 0 AND beta_unclustered == 0 => mu is exactly 0
- # (no latent term, no weak-signal term).
- set.seed(53)
- g0 <- genZmuY(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
- n_clusters = 2, sig_clusters = 0, beta_latent = 1.5,
- beta_unclustered = 0, snr = NA, sigma_eps_sq = 0.5)
- testthat::expect_true(all(g0$mu == 0))
-
- # Contrast, n_clusters > 1: reset the seed before EACH call so the SAME
- # orig_feat_mat (hence the same Z and weak-signal block) is drawn; then
- # g1$mu - g0$mu isolates the pure latent term Z[, 1] * beta_latent.
- cfgA <- list(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
- n_clusters = 2, beta_latent = 1.5, beta_unclustered = 1,
- snr = NA, sigma_eps_sq = 0.5)
- set.seed(51)
- g0A <- do.call(genZmuY, c(cfgA, sig_clusters = 0))
- set.seed(51)
- g1A <- do.call(genZmuY, c(cfgA, sig_clusters = 1))
- testthat::expect_equal(g1A$Z, g0A$Z) # same orig_feat_mat drawn
- testthat::expect_false(all(g0A$mu == 0)) # weak signal still retained
- testthat::expect_equal(g1A$mu - g0A$mu, as.numeric(g1A$Z[, 1] * 1.5))
- # Lock the n_clusters > 1 & sig_clusters == 1 branch with an explicit
- # expected value (no characterization snapshot covers it).
- testthat::expect_equal(g1A$mu[1:4], c(1.71187484261165, -1.8816097377914,
- -0.434623721956133, 0.201053072650191))
-
- # Contrast, n_clusters == 1 (Z is a bare vector; the else branch).
- cfgB <- list(n = 20, p = 4, k_unclustered = 1, cluster_size = 2,
- n_clusters = 1, beta_latent = 1.5, beta_unclustered = 1,
- snr = NA, sigma_eps_sq = 0.5)
- set.seed(52)
- g0B <- do.call(genZmuY, c(cfgB, sig_clusters = 0))
- set.seed(52)
- g1B <- do.call(genZmuY, c(cfgB, sig_clusters = 1))
- testthat::expect_equal(g1B$mu - g0B$mu, as.numeric(g1B$Z * 1.5))
- testthat::expect_equal(g1B$mu[1:4], c(-1.35778032140589, 0.59232273049822,
- 2.44822804281879, -0.29256382836018))
-
- # End-to-end: genClusteredData with sig_clusters = 0 and NONZERO default
- # betas returns valid data (no error; the weak-signal features still
- # legitimately contribute, only the latent part is zeroed).
- ret <- genClusteredData(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
- n_clusters = 2, sig_clusters = 0, sigma_eps_sq = 0.5)
- testthat::expect_true(is.list(ret))
- testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
- testthat::expect_equal(ncol(ret$X), 6)
-})
+testthat::test_that("genZmuY one-weak-signal config no longer crashes, all 3 generators (#124 bug 1)", {
+ # p == n_clusters*cluster_size + 1 leaves exactly ONE weak-signal/noise
+ # feature, so other_X had a single column; without drop = FALSE it collapsed
+ # to a vector and other_X[, j] errored "incorrect number of dimensions". The
+ # pre-check only requires p_orig_feat_mat >= k_unclustered + n_clusters
+ # (here 2 >= 2), so it passed straight into the crash.
+ ret <- genClusteredData(n = 20, p = 3, k_unclustered = 1, cluster_size = 2,
+ n_clusters = 1, snr = 2)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_true(is.matrix(ret$X))
+ testthat::expect_equal(ncol(ret$X), 3)
+ testthat::expect_equal(nrow(ret$X), 20)
+
+ # genClusteredDataWeighted: n_strong_cluster_vars is REQUIRED and its checker
+ # enforces >= 1 AND < cluster_size, so with cluster_size = 2 the only valid
+ # value is 1.
+ retW <- genClusteredDataWeighted(n = 20, p = 3, k_unclustered = 1,
+ cluster_size = 2, n_clusters = 1,
+ n_strong_cluster_vars = 1, snr = 2)
+ testthat::expect_true(is.list(retW))
+ testthat::expect_identical(names(retW), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ncol(retW$X), 3)
+
+ retR <- genClusteredDataWeightedRandom(n = 20, p = 3, k_unclustered = 1,
+ cluster_size = 2, n_clusters = 1,
+ snr = 2)
+ testthat::expect_true(is.list(retR))
+ testthat::expect_identical(names(retR), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ncol(retR$X), 3)
+})
+
+testthat::test_that("genZmuY sig_clusters == 0 yields a null latent model (#124 bug 2)", {
+ # The zero-beta case MUST bypass genClusteredData: its validator rejects
+ # beta_unclustered == 0 / beta_latent == 0, so exercise the internal helper
+ # directly. sig_clusters == 0 AND beta_unclustered == 0 => mu is exactly 0
+ # (no latent term, no weak-signal term).
+ set.seed(53)
+ g0 <- genZmuY(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
+ n_clusters = 2, sig_clusters = 0, beta_latent = 1.5,
+ beta_unclustered = 0, snr = NA, sigma_eps_sq = 0.5)
+ testthat::expect_true(all(g0$mu == 0))
+
+ # Contrast, n_clusters > 1: reset the seed before EACH call so the SAME
+ # orig_feat_mat (hence the same Z and weak-signal block) is drawn; then
+ # g1$mu - g0$mu isolates the pure latent term Z[, 1] * beta_latent.
+ cfgA <- list(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
+ n_clusters = 2, beta_latent = 1.5, beta_unclustered = 1,
+ snr = NA, sigma_eps_sq = 0.5)
+ set.seed(51)
+ g0A <- do.call(genZmuY, c(cfgA, sig_clusters = 0))
+ set.seed(51)
+ g1A <- do.call(genZmuY, c(cfgA, sig_clusters = 1))
+ testthat::expect_equal(g1A$Z, g0A$Z) # same orig_feat_mat drawn
+ testthat::expect_false(all(g0A$mu == 0)) # weak signal still retained
+ testthat::expect_equal(g1A$mu - g0A$mu, as.numeric(g1A$Z[, 1] * 1.5))
+ # Lock the n_clusters > 1 & sig_clusters == 1 branch with an explicit
+ # expected value (no characterization snapshot covers it).
+ testthat::expect_equal(g1A$mu[1:4], c(1.71187484261165, -1.8816097377914,
+ -0.434623721956133, 0.201053072650191))
+
+ # Contrast, n_clusters == 1 (Z is a bare vector; the else branch).
+ cfgB <- list(n = 20, p = 4, k_unclustered = 1, cluster_size = 2,
+ n_clusters = 1, beta_latent = 1.5, beta_unclustered = 1,
+ snr = NA, sigma_eps_sq = 0.5)
+ set.seed(52)
+ g0B <- do.call(genZmuY, c(cfgB, sig_clusters = 0))
+ set.seed(52)
+ g1B <- do.call(genZmuY, c(cfgB, sig_clusters = 1))
+ testthat::expect_equal(g1B$mu - g0B$mu, as.numeric(g1B$Z * 1.5))
+ testthat::expect_equal(g1B$mu[1:4], c(-1.35778032140589, 0.59232273049822,
+ 2.44822804281879, -0.29256382836018))
+
+ # End-to-end: genClusteredData with sig_clusters = 0 and NONZERO default
+ # betas returns valid data (no error; the weak-signal features still
+ # legitimately contribute, only the latent part is zeroed).
+ ret <- genClusteredData(n = 20, p = 6, k_unclustered = 1, cluster_size = 2,
+ n_clusters = 2, sig_clusters = 0, sigma_eps_sq = 0.5)
+ testthat::expect_true(is.list(ret))
+ testthat::expect_identical(names(ret), c("X", "y", "Z", "mu"))
+ testthat::expect_equal(ncol(ret$X), 6)
+})
## Test passed with 11 successes.
## Test passed with 10 successes.
Tests for getLassoLambda():
-testthat::test_that("getLassoLambda works", {
- set.seed(7252)
-
- x <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
- y <- stats::rnorm(10)
-
- ret <- getLassoLambda(X=x, y=y, lambda_choice="1se", nfolds=4)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_true(ret >= 0)
-
- ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_true(ret >= 0)
-
- # Different mixing parameter
-
- ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5, alpha=0.5)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_true(ret >= 0)
-
- # data.frame X is now accepted (coerced internally), like the sibling exports (#51)
- ret_df <- getLassoLambda(X = as.data.frame(x), y = y, lambda_choice = "1se", nfolds = 4)
- testthat::expect_true(is.numeric(ret_df) | is.integer(ret_df))
- testthat::expect_true(!is.na(ret_df))
- testthat::expect_equal(length(ret_df), 1)
- testthat::expect_true(ret_df >= 0)
-
- # Bad inputs
- testthat::expect_error(getLassoLambda(X="x", y=y), "must be a numeric matrix",
- fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x[1:9, ], y=y),
- "n == length(y) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=TRUE),
- "must be a numeric (real-valued) vector",
- fixed=TRUE)
-
- # Error has quotation marks in it
- testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice="mni"))
-
- testthat::expect_error(getLassoLambda(X=x, y=y,
- lambda_choice=c("min", "1se")),
- "length(lambda_choice) == 1 is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=1),
- "is.character(lambda_choice) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds="5"),
- "is.numeric(nfolds) | is.integer(nfolds) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=1:4),
- "length(nfolds) == 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=3.2),
- "nfolds == round(nfolds) is not TRUE", fixed=TRUE)
-
- # (#158e) nfolds=3 is cv.glmnet's minimum and is now accepted.
- ret <- getLassoLambda(X=x, y=y, nfolds=3)
- testthat::expect_true(is.numeric(ret) && length(ret) == 1 && ret >= 0)
- # nfolds=2 (below the minimum) is rejected at the new boundary.
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=2),
- "nfolds >= 3 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=1.2),
- "alpha <= 1 is not TRUE", fixed=TRUE)
-
- # alpha = 0 (degenerate ridge) is now rejected (previously allowed)
- testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=0),
- "alpha > 0 is not TRUE", fixed=TRUE)
-
- # An NA in the design matrix now yields a friendly message (#56) rather than
- # falling through to a cryptic glmnet-level error.
- x_na <- x; x_na[2, 1] <- NA
- testthat::expect_error(getLassoLambda(X=x_na, y=y),
- "must not contain missing", fixed=TRUE)
- # A data.frame with a numeric NA must error with the same message BEFORE
- # coercion: model.matrix's na.action=na.omit would otherwise silently drop
- # the NA row and the failure would surface downstream (length mismatch), not
- # as this message. This case pins the pre-coercion placement of checkNoNAs.
- df_na <- as.data.frame(x); df_na[2, 1] <- NA
- testthat::expect_error(getLassoLambda(X=df_na, y=y),
- "must not contain missing", fixed=TRUE)
-
- # (#104, L7) When n is too small for even 3-fold cross-validation, error
- # clearly here instead of crashing inside cv.glmnet ("nfolds must be bigger
- # than 3"). With n = 4 and the default nfolds = 10, n_sample rounds to 2 (< 3).
- testthat::expect_error(
- getLassoLambda(X=matrix(stats::rnorm(4*5), nrow=4, ncol=5),
- y=stats::rnorm(4)),
- "is too small to choose lambda", fixed=TRUE)
-
- # (#127) A single-column X now fires the same clean "p >= 2 is not TRUE"
- # message as css(), rather than crashing later inside cv.glmnet.
- testthat::expect_error(
- getLassoLambda(X=matrix(stats::rnorm(40), nrow=40, ncol=1),
- y=stats::rnorm(40)),
- "p >= 2 is not TRUE", fixed=TRUE)
-
-})
+testthat::test_that("getLassoLambda works", {
+ set.seed(7252)
+
+ x <- matrix(stats::rnorm(10*6), nrow=10, ncol=6)
+ y <- stats::rnorm(10)
+
+ ret <- getLassoLambda(X=x, y=y, lambda_choice="1se", nfolds=4)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_true(ret >= 0)
+
+ ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_true(ret >= 0)
+
+ # Different mixing parameter
+
+ ret <- getLassoLambda(X=x, y=y, lambda_choice="min", nfolds=5, alpha=0.5)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_true(ret >= 0)
+
+ # data.frame X is now accepted (coerced internally), like the sibling exports (#51)
+ ret_df <- getLassoLambda(X = as.data.frame(x), y = y, lambda_choice = "1se", nfolds = 4)
+ testthat::expect_true(is.numeric(ret_df) | is.integer(ret_df))
+ testthat::expect_true(!is.na(ret_df))
+ testthat::expect_equal(length(ret_df), 1)
+ testthat::expect_true(ret_df >= 0)
+
+ # Bad inputs
+ testthat::expect_error(getLassoLambda(X="x", y=y), "must be a numeric matrix",
+ fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x[1:9, ], y=y),
+ "n == length(y) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=TRUE),
+ "must be a numeric (real-valued) vector",
+ fixed=TRUE)
+
+ # Error has quotation marks in it
+ testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice="mni"))
+
+ testthat::expect_error(getLassoLambda(X=x, y=y,
+ lambda_choice=c("min", "1se")),
+ "length(lambda_choice) == 1 is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=y, lambda_choice=1),
+ "is.character(lambda_choice) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds="5"),
+ "is.numeric(nfolds) | is.integer(nfolds) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=1:4),
+ "length(nfolds) == 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=3.2),
+ "nfolds == round(nfolds) is not TRUE", fixed=TRUE)
+
+ # (#158e) nfolds=3 is cv.glmnet's minimum and is now accepted.
+ ret <- getLassoLambda(X=x, y=y, nfolds=3)
+ testthat::expect_true(is.numeric(ret) && length(ret) == 1 && ret >= 0)
+ # nfolds=2 (below the minimum) is rejected at the new boundary.
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=2),
+ "nfolds >= 3 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=1.2),
+ "alpha <= 1 is not TRUE", fixed=TRUE)
+
+ # alpha = 0 (degenerate ridge) is now rejected (previously allowed)
+ testthat::expect_error(getLassoLambda(X=x, y=y, nfolds=4, alpha=0),
+ "alpha > 0 is not TRUE", fixed=TRUE)
+
+ # An NA in the design matrix now yields a friendly message (#56) rather than
+ # falling through to a cryptic glmnet-level error.
+ x_na <- x; x_na[2, 1] <- NA
+ testthat::expect_error(getLassoLambda(X=x_na, y=y),
+ "must not contain missing", fixed=TRUE)
+ # A data.frame with a numeric NA must error with the same message BEFORE
+ # coercion: model.matrix's na.action=na.omit would otherwise silently drop
+ # the NA row and the failure would surface downstream (length mismatch), not
+ # as this message. This case pins the pre-coercion placement of checkNoNAs.
+ df_na <- as.data.frame(x); df_na[2, 1] <- NA
+ testthat::expect_error(getLassoLambda(X=df_na, y=y),
+ "must not contain missing", fixed=TRUE)
+
+ # (#104, L7) When n is too small for even 3-fold cross-validation, error
+ # clearly here instead of crashing inside cv.glmnet ("nfolds must be bigger
+ # than 3"). With n = 4 and the default nfolds = 10, n_sample rounds to 2 (< 3).
+ testthat::expect_error(
+ getLassoLambda(X=matrix(stats::rnorm(4*5), nrow=4, ncol=5),
+ y=stats::rnorm(4)),
+ "is too small to choose lambda", fixed=TRUE)
+
+ # (#127) A single-column X now fires the same clean "p >= 2 is not TRUE"
+ # message as css(), rather than crashing later inside cv.glmnet.
+ testthat::expect_error(
+ getLassoLambda(X=matrix(stats::rnorm(40), nrow=40, ncol=1),
+ y=stats::rnorm(40)),
+ "p >= 2 is not TRUE", fixed=TRUE)
+
+})
## Test passed with 33 successes.
Out-of-range cluster indices are caught up front (#104, L3) through the public
css() and protolasso() entry points – covering a bare-vector clusters
argument (which is wrapped into a list after the per-element validation loop) and
a list clusters argument:
-testthat::test_that("out-of-range cluster indices error via css/protolasso (#104)", {
- set.seed(104105)
- X <- matrix(stats::rnorm(20*8), nrow=20, ncol=8)
- y <- stats::rnorm(20)
-
- # Bare-vector clusters with an index beyond p (= 5 here).
- testthat::expect_error(
- css(X[, 1:5], y, lambda=0.01, clusters=c(1, 2, 99)),
- "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE)
-
- # List clusters routed through protolasso.
- testthat::expect_error(
- protolasso(X[, 1:5], y, clusters=list(c(1, 2, 99))),
- "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE)
-})
+testthat::test_that("out-of-range cluster indices error via css/protolasso (#104)", {
+ set.seed(104105)
+ X <- matrix(stats::rnorm(20*8), nrow=20, ncol=8)
+ y <- stats::rnorm(20)
+
+ # Bare-vector clusters with an index beyond p (= 5 here).
+ testthat::expect_error(
+ css(X[, 1:5], y, lambda=0.01, clusters=c(1, 2, 99)),
+ "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE)
+
+ # List clusters routed through protolasso.
+ testthat::expect_error(
+ protolasso(X[, 1:5], y, clusters=list(c(1, 2, 99))),
+ "Cluster index 99 exceeds the number of features (p = 5).", fixed=TRUE)
+})
## Test passed with 2 successes.
css() reports a too-small sample size clearly (#104, L4) instead of the
misleading “Too many training indices provided” when no training indices were
supplied:
-testthat::test_that("css reports a too-small sample size clearly (#104)", {
- set.seed(104104)
-
- # No train_inds: the message must blame the sample size, not training indices.
- testthat::expect_error(
- css(matrix(stats::rnorm(15), nrow=3, ncol=5), stats::rnorm(3), lambda=0.01),
- "is too small", fixed=TRUE)
-
- # When train_inds leave fewer than 4 observations for selection, the original
- # "Too many training indices" branch still fires.
- testthat::expect_error(
- css(matrix(stats::rnorm(10*5), nrow=10, ncol=5), stats::rnorm(10),
- lambda=0.01, train_inds=1:7),
- "Too many training indices provided", fixed=TRUE)
-})
+testthat::test_that("css reports a too-small sample size clearly (#104)", {
+ set.seed(104104)
+
+ # No train_inds: the message must blame the sample size, not training indices.
+ testthat::expect_error(
+ css(matrix(stats::rnorm(15), nrow=3, ncol=5), stats::rnorm(3), lambda=0.01),
+ "is too small", fixed=TRUE)
+
+ # When train_inds leave fewer than 4 observations for selection, the original
+ # "Too many training indices" branch still fires.
+ testthat::expect_error(
+ css(matrix(stats::rnorm(10*5), nrow=10, ncol=5), stats::rnorm(10),
+ lambda=0.01, train_inds=1:7),
+ "Too many training indices provided", fixed=TRUE)
+})
## Test passed with 2 successes.
Tests for getModelSize():
-testthat::test_that("getModelSize works", {
- set.seed(1723)
-
- data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sigma_eps_sq=10^(-6))
-
- x <- data$X
- y <- data$y
-
- good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
-
- ret <- getModelSize(X=x, y=y, clusters=good_clusters)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_equal(ret, round(ret))
- testthat::expect_true(ret >= 1)
- # 11 features, but two clusters of size 3, so maximum size should
- # be 11 - 2 - 2 = 7
- testthat::expect_true(ret <= 7)
-
- ## Trying other inputs
-
- unnamed_clusters <- list(1L:3L, 5L:8L)
-
- ret <- getModelSize(X=x, y=y, clusters=unnamed_clusters)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_equal(ret, round(ret))
- testthat::expect_true(ret >= 1)
- # 11 features, but 3 in one cluster and 4 in another, so maximum size should
- # be 11 - 2 - 3 = 6
- testthat::expect_true(ret <= 6)
-
- # Single cluster
- ret <- getModelSize(X=x, y=y, clusters=2:5)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_equal(ret, round(ret))
- testthat::expect_true(ret >= 1)
- # 11 features, but 4 in one cluster, so maximum size should be 11 - 3 = 8
- testthat::expect_true(ret <= 8)
-
- # Regression test: when prototype reduction leaves a single column (all
- # provided features in one cluster), getModelSize must return 1L rather than
- # crashing in cv.glmnet. Previously X_size[, -feats_to_drop] dropped to a
- # vector when one column remained.
- testthat::expect_equal(getModelSize(X=x[, 1:3, drop=FALSE], y=y,
- clusters=list(1:3)), 1L)
-
-
- # Intentionally don't provide clusters for all feature, mix up formatting,
- # etc.
- good_clusters <- list(red_cluster=1:3, 5:8)
-
- ret <- getModelSize(X=x, y=y, clusters=good_clusters)
-
- testthat::expect_true(is.numeric(ret) | is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_equal(ret, round(ret))
- testthat::expect_true(ret >= 1)
- # 11 features, but 3 in one cluster and 4 in another, so maximum size should
- # be 11 - 2 - 3 = 6
- testthat::expect_true(ret <= 6)
-
- ## Trying bad inputs
-
- testthat::expect_error(getModelSize(X="x", y=y, clusters=good_clusters),
- "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x[1:5, ], y=y, clusters=good_clusters),
- "length(y) == n is not TRUE", fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=FALSE, clusters=good_clusters),
- "must be a numeric (real-valued) vector",
- fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=y, clusters=list(3:7, 7:10)),
- "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.",
- fixed=TRUE)
-
- # Duplicate clusters are now silently removed (#156): the model size for a
- # duplicated cluster equals that of the deduplicated input. getModelSize is
- # stochastic (cv.glmnet), so seed both calls identically.
- set.seed(15678)
- dup_ms <- getModelSize(X=x, y=y, clusters=list(5:8, 5:8))
- set.seed(15678)
- dedup_ms <- getModelSize(X=x, y=y, clusters=list(5:8))
- testthat::expect_equal(dup_ms, dedup_ms)
-
- # Out-of-range cluster index now caught up front by checkFormatClustersInput
- # (#104, L3); x has 11 columns, so index 50 is out of range.
- testthat::expect_error(getModelSize(X=x, y=y, clusters=6:50),
- "Cluster index 50 exceeds the number of features (p = 11).",
- fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=y,
- clusters=list(2:3, as.integer(NA))),
- "!is.na(clusters) are not all TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, c(4, 4, 5))),
- "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, -1)),
- "all(clusters[[i]] >= 1) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4,
- c(2.3, 1.2))),
- "all(clusters[[i]] == round(clusters[[i]])) is not TRUE",
- fixed=TRUE)
-
- ## alpha (#21): the elastic-net mixing parameter now drives the model-size
- ## estimate (the internal cv.glmnet), keeping it consistent with elastic-net
- ## feature selection.
-
- # Validation, mirroring getLassoLambda: alpha must be in (0, 1].
- testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=0),
- "alpha > 0 is not TRUE", fixed=TRUE)
- testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=1.5),
- "alpha <= 1 is not TRUE", fixed=TRUE)
- testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=NA),
- "is.numeric(alpha) | is.integer(alpha) is not TRUE",
- fixed=TRUE)
-
- # Back-compat: default is pure lasso (alpha = 1). cv.glmnet uses random CV
- # folds, so seed before each call to compare apples-to-apples.
- set.seed(7); a_default <- getModelSize(X=x, y=y, clusters=good_clusters)
- set.seed(7); a_alpha1 <- getModelSize(X=x, y=y, clusters=good_clusters, alpha=1)
- testthat::expect_equal(a_default, a_alpha1)
-
- # Headline: on a design with a block of highly correlated relevant features
- # (each feature its own singleton cluster, so cv.glmnet sees the whole block
- # with no prototype reduction), a lower alpha (elastic net) keeps more of the
- # correlated features than pure lasso, giving a strictly larger estimated
- # size. On main, getModelSize has no alpha argument, so this cannot happen.
- set.seed(2718)
- n_h <- 120
- z_h <- stats::rnorm(n_h)
- X_block <- matrix(rep(z_h, 10), nrow=n_h) +
- matrix(stats::rnorm(n_h * 10, sd=0.05), nrow=n_h)
- X_noise <- matrix(stats::rnorm(n_h * 4), nrow=n_h)
- X_h <- cbind(X_block, X_noise)
- y_h <- 2 * z_h + stats::rnorm(n_h, sd=0.5)
- singletons_h <- as.list(1:ncol(X_h))
- set.seed(11)
- size_lasso <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=1)
- set.seed(11)
- size_enet <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=0.2)
- testthat::expect_true(size_enet >= size_lasso)
- testthat::expect_true(size_enet > size_lasso)
-
-})
+testthat::test_that("getModelSize works", {
+ set.seed(1723)
+
+ data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sigma_eps_sq=10^(-6))
+
+ x <- data$X
+ y <- data$y
+
+ good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
+
+ ret <- getModelSize(X=x, y=y, clusters=good_clusters)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_equal(ret, round(ret))
+ testthat::expect_true(ret >= 1)
+ # 11 features, but two clusters of size 3, so maximum size should
+ # be 11 - 2 - 2 = 7
+ testthat::expect_true(ret <= 7)
+
+ ## Trying other inputs
+
+ unnamed_clusters <- list(1L:3L, 5L:8L)
+
+ ret <- getModelSize(X=x, y=y, clusters=unnamed_clusters)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_equal(ret, round(ret))
+ testthat::expect_true(ret >= 1)
+ # 11 features, but 3 in one cluster and 4 in another, so maximum size should
+ # be 11 - 2 - 3 = 6
+ testthat::expect_true(ret <= 6)
+
+ # Single cluster
+ ret <- getModelSize(X=x, y=y, clusters=2:5)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_equal(ret, round(ret))
+ testthat::expect_true(ret >= 1)
+ # 11 features, but 4 in one cluster, so maximum size should be 11 - 3 = 8
+ testthat::expect_true(ret <= 8)
+
+ # Regression test: when prototype reduction leaves a single column (all
+ # provided features in one cluster), getModelSize must return 1L rather than
+ # crashing in cv.glmnet. Previously X_size[, -feats_to_drop] dropped to a
+ # vector when one column remained.
+ testthat::expect_equal(getModelSize(X=x[, 1:3, drop=FALSE], y=y,
+ clusters=list(1:3)), 1L)
+
+
+ # Intentionally don't provide clusters for all feature, mix up formatting,
+ # etc.
+ good_clusters <- list(red_cluster=1:3, 5:8)
+
+ ret <- getModelSize(X=x, y=y, clusters=good_clusters)
+
+ testthat::expect_true(is.numeric(ret) | is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_equal(ret, round(ret))
+ testthat::expect_true(ret >= 1)
+ # 11 features, but 3 in one cluster and 4 in another, so maximum size should
+ # be 11 - 2 - 3 = 6
+ testthat::expect_true(ret <= 6)
+
+ ## Trying bad inputs
+
+ testthat::expect_error(getModelSize(X="x", y=y, clusters=good_clusters),
+ "is.matrix(X) | is.data.frame(X) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x[1:5, ], y=y, clusters=good_clusters),
+ "length(y) == n is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=FALSE, clusters=good_clusters),
+ "must be a numeric (real-valued) vector",
+ fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=list(3:7, 7:10)),
+ "Overlapping clusters detected; clusters must be non-overlapping. Overlapping clusters: 1, 2.",
+ fixed=TRUE)
+
+ # Duplicate clusters are now silently removed (#156): the model size for a
+ # duplicated cluster equals that of the deduplicated input. getModelSize is
+ # stochastic (cv.glmnet), so seed both calls identically.
+ set.seed(15678)
+ dup_ms <- getModelSize(X=x, y=y, clusters=list(5:8, 5:8))
+ set.seed(15678)
+ dedup_ms <- getModelSize(X=x, y=y, clusters=list(5:8))
+ testthat::expect_equal(dup_ms, dedup_ms)
+
+ # Out-of-range cluster index now caught up front by checkFormatClustersInput
+ # (#104, L3); x has 11 columns, so index 50 is out of range.
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=6:50),
+ "Cluster index 50 exceeds the number of features (p = 11).",
+ fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=y,
+ clusters=list(2:3, as.integer(NA))),
+ "!is.na(clusters) are not all TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=list(2:3, c(4, 4, 5))),
+ "length(clusters[[i]]) == length(unique(clusters[[i]])) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4, -1)),
+ "all(clusters[[i]] >= 1) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=list(1:4,
+ c(2.3, 1.2))),
+ "all(clusters[[i]] == round(clusters[[i]])) is not TRUE",
+ fixed=TRUE)
+
+ ## alpha (#21): the elastic-net mixing parameter now drives the model-size
+ ## estimate (the internal cv.glmnet), keeping it consistent with elastic-net
+ ## feature selection.
+
+ # Validation, mirroring getLassoLambda: alpha must be in (0, 1].
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=0),
+ "alpha > 0 is not TRUE", fixed=TRUE)
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=1.5),
+ "alpha <= 1 is not TRUE", fixed=TRUE)
+ testthat::expect_error(getModelSize(X=x, y=y, clusters=good_clusters, alpha=NA),
+ "is.numeric(alpha) | is.integer(alpha) is not TRUE",
+ fixed=TRUE)
+
+ # Back-compat: default is pure lasso (alpha = 1). cv.glmnet uses random CV
+ # folds, so seed before each call to compare apples-to-apples.
+ set.seed(7); a_default <- getModelSize(X=x, y=y, clusters=good_clusters)
+ set.seed(7); a_alpha1 <- getModelSize(X=x, y=y, clusters=good_clusters, alpha=1)
+ testthat::expect_equal(a_default, a_alpha1)
+
+ # Headline: on a design with a block of highly correlated relevant features
+ # (each feature its own singleton cluster, so cv.glmnet sees the whole block
+ # with no prototype reduction), a lower alpha (elastic net) keeps more of the
+ # correlated features than pure lasso, giving a strictly larger estimated
+ # size. On main, getModelSize has no alpha argument, so this cannot happen.
+ set.seed(2718)
+ n_h <- 120
+ z_h <- stats::rnorm(n_h)
+ X_block <- matrix(rep(z_h, 10), nrow=n_h) +
+ matrix(stats::rnorm(n_h * 10, sd=0.05), nrow=n_h)
+ X_noise <- matrix(stats::rnorm(n_h * 4), nrow=n_h)
+ X_h <- cbind(X_block, X_noise)
+ y_h <- 2 * z_h + stats::rnorm(n_h, sd=0.5)
+ singletons_h <- as.list(1:ncol(X_h))
+ set.seed(11)
+ size_lasso <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=1)
+ set.seed(11)
+ size_enet <- getModelSize(X=X_h, y=y_h, clusters=singletons_h, alpha=0.2)
+ testthat::expect_true(size_enet >= size_lasso)
+ testthat::expect_true(size_enet > size_lasso)
+
+})
## Test passed with 41 successes.
These two functions are the package’s only cv.glmnet call sites, and #186’s fix
is a grouped argument on each. This block is what observes that fix:
-testthat::test_that("small-n cv.glmnet calls do not leak glmnet's fold-size nag (#186)", {
- set.seed(186)
- X <- matrix(stats::rnorm(20 * 6), nrow = 20, ncol = 6)
- y <- as.numeric(X %*% c(1, -1, 0, 0, 0, 0) + stats::rnorm(20))
-
- # n = 20 puts both calls under glmnet's nrow(x)/nfolds < 3 rule -- getLassoLambda
- # subsamples 11 rows over 10 folds, getModelSize passes all 20 over 10 -- so
- # without the explicit grouped argument cv.glmnet warns here. capture_warnings()
- # rather than expect_no_warning() because the woven chunks run at testthat
- # edition 2, where this form behaves the same as it does under devtools::test().
- lambda_warns <- testthat::capture_warnings(lambda <- getLassoLambda(X = X, y = y))
- testthat::expect_length(lambda_warns, 0)
- testthat::expect_true(is.numeric(lambda) & length(lambda) == 1)
-
- size_warns <- testthat::capture_warnings(
- size <- getModelSize(X = X, y = y, clusters = list(1:3)))
- testthat::expect_length(size_warns, 0)
- testthat::expect_true(is.integer(size) & size >= 1)
-
- # The user-visible half of #186: under options(warn = 2) the unguarded calls
- # became errors, so cssSelect()/cssPredict() were unusable at small n.
- old_warn <- options(warn = 2)
- on.exit(options(old_warn), add = TRUE)
- testthat::expect_no_error(getLassoLambda(X = X, y = y))
- testthat::expect_no_error(getModelSize(X = X, y = y, clusters = list(1:3)))
-})
+testthat::test_that("small-n cv.glmnet calls do not leak glmnet's fold-size nag (#186)", {
+ set.seed(186)
+ X <- matrix(stats::rnorm(20 * 6), nrow = 20, ncol = 6)
+ y <- as.numeric(X %*% c(1, -1, 0, 0, 0, 0) + stats::rnorm(20))
+
+ # n = 20 puts both calls under glmnet's nrow(x)/nfolds < 3 rule -- getLassoLambda
+ # subsamples 11 rows over 10 folds, getModelSize passes all 20 over 10 -- so
+ # without the explicit grouped argument cv.glmnet warns here. capture_warnings()
+ # rather than expect_no_warning() because the woven chunks run at testthat
+ # edition 2, where this form behaves the same as it does under devtools::test().
+ lambda_warns <- testthat::capture_warnings(lambda <- getLassoLambda(X = X, y = y))
+ testthat::expect_length(lambda_warns, 0)
+ testthat::expect_true(is.numeric(lambda) & length(lambda) == 1)
+
+ size_warns <- testthat::capture_warnings(
+ size <- getModelSize(X = X, y = y, clusters = list(1:3)))
+ testthat::expect_length(size_warns, 0)
+ testthat::expect_true(is.integer(size) & size >= 1)
+
+ # The user-visible half of #186: under options(warn = 2) the unguarded calls
+ # became errors, so cssSelect()/cssPredict() were unusable at small n.
+ old_warn <- options(warn = 2)
+ on.exit(options(old_warn), add = TRUE)
+ testthat::expect_no_error(getLassoLambda(X = X, y = y))
+ testthat::expect_no_error(getModelSize(X = X, y = y, clusters = list(1:3)))
+})
## Test passed with 6 successes.
Tests for getSelectionPrototypes():
-testthat::test_that("getSelectionPrototypes works", {
- set.seed(67234)
-
- data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
-
- x <- data$X
- y <- data$y
-
- good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
-
- css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters)
-
- ret <- getSelectionPrototypes(css_results, selected_clusts=good_clusters)
-
- testthat::expect_true(is.integer(ret))
- testthat::expect_true(all(!is.na(ret)))
- testthat::expect_equal(length(ret), length(good_clusters))
- testthat::expect_equal(length(ret), length(unique(ret)))
- for(i in 1:length(ret)){
- testthat::expect_true(ret[i] %in% good_clusters[[i]])
- # Find the largest selection proportion of any feature in cluster i
- max_prop <- max(colMeans(css_results$feat_sel_mat[, good_clusters[[i]]]))
- # Find the selection proportion of the identified prototype
- proto_prop <- colMeans(css_results$feat_sel_mat)[ret[i]]
- testthat::expect_equal(max_prop, proto_prop)
- }
-
- # Try with only one selected cluster (still should be in a list)
-
- ret <- getSelectionPrototypes(css_results,
- selected_clusts=list(red_cluster=1L:3L))
-
- testthat::expect_true(is.integer(ret))
- testthat::expect_true(!is.na(ret))
- testthat::expect_equal(length(ret), 1)
- testthat::expect_true(ret %in% 1L:3L)
- # Find the largest selection proportion of any feature in the cluster
- max_prop <- max(colMeans(css_results$feat_sel_mat[, 1L:3L]))
- # Find the selection proportion of the identified prototype
- proto_prop <- colMeans(css_results$feat_sel_mat)[ret]
- testthat::expect_equal(max_prop, proto_prop)
-
- ## Trying bad inputs
-
- # Error contains quotation marks
- testthat::expect_error(getSelectionPrototypes(x, good_clusters))
-
- testthat::expect_error(getSelectionPrototypes(css_results, 1L:3L),
- "is.list(selected_clusts) is not TRUE", fixed=TRUE)
-
- # An empty selection (empty list of selected clusters) is valid post-#107:
- # getSelectionPrototypes() returns an empty integer vector, no error (#120).
- testthat::expect_identical(getSelectionPrototypes(css_results, list()),
- integer(0))
-
- testthat::expect_error(getSelectionPrototypes(css_results,
- list(red_cluster=1L:3L,
- green_cluster=4L:6L,
- bad_cluster=integer())),
- "all(lengths(selected_clusts) >= 1) is not TRUE",
- fixed=TRUE)
-
-})
-
-testthat::test_that("getSelectionPrototypes handles a constant tied column without crashing (#68)", {
- set.seed(680)
- n <- 20L; p <- 4L
- X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
- X[, 2] <- 3.5 # feature 2 is a CONSTANT column
- colnames(X) <- paste0("V", 1:p)
- y <- X[, 1] + stats::rnorm(n) # y correlated with feature 1 (varying)
- # feat_sel_mat: features 1 and 2 tie at selection proportion 0.5 (both
- # "selected" in the same 5 of 10 subsamples), forcing the tie-break path.
- B <- 10L
- M <- matrix(0L, nrow = B, ncol = p)
- M[1:5, 1] <- 1L
- M[1:5, 2] <- 1L
- css_results <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
- # Pre-fix: cor(X[, c(1,2)], y) -> c(<corr>, NA) -> max NA -> stopifnot abort.
- proto <- getSelectionPrototypes(css_results, selected_clusts = list(c(1L, 2L)))
- testthat::expect_false(is.na(proto))
- testthat::expect_identical(unname(proto), 1L) # the varying, y-correlated member
-
- # All-constant tied cluster: must not crash, picks the first deterministically.
- # (suppressWarnings: the names-assignment emits a pre-existing "number of items
- # to replace..." warning when proto_i stays length>1; not introduced by this
- # fix, unrelated to #68.)
- X2 <- X; X2[, 3] <- 2.0; X2[, 4] <- 9.0
- M2 <- matrix(0L, nrow = B, ncol = p); M2[1:5, 3] <- 1L; M2[1:5, 4] <- 1L
- css2 <- structure(list(X = X2, y = y, feat_sel_mat = M2), class = "cssr")
- proto2 <- suppressWarnings(
- getSelectionPrototypes(css2, selected_clusts = list(c(3L, 4L))))
- testthat::expect_identical(unname(proto2), 3L)
-})
-
-testthat::test_that("getSelectionPrototypes skips the correlation tie-break for non-numeric y (#128)", {
- # css() accepts a non-numeric y (response validation is delegated to fitfun),
- # so getSelectionPrototypes must NOT call cor() -- which requires a numeric y --
- # when breaking a selection-proportion tie. Hand-build a cssr object with a
- # CHARACTER y and a feat_sel_mat in which members 1 and 2 tie (equal column
- # means) so the tie block IS entered (length(proto_i) > 1). Without the
- # is.numeric(y) guard, cor(X[, 1:2], <character y>) would error; the guard skips
- # it and the first tied index is returned deterministically.
- B <- 10L; p <- 2L; n <- 8L
- X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
- colnames(X) <- paste0("V", 1:p)
- y <- letters[1:n] # non-numeric (character) response
- M <- matrix(0L, nrow = B, ncol = p)
- M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5,
- M[1:5, 2] <- 1L # forcing the tie-break path
- css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
- # suppressWarnings: an unbroken length-2 tie triggers a benign R "number of
- # items to replace" warning at the names-assignment (it fires for ANY persisted
- # tie, incl. the numeric #68 case) that would otherwise fail testthat edition 3.
- res <- suppressWarnings(getSelectionPrototypes(css, list(c(1L, 2L))))
- testthat::expect_identical(unname(res), 1L) # first tied index, deterministic
-})
-
-testthat::test_that("getSelectionPrototypes emits no warning on an unbroken tie (#126)", {
- # Item-5 regression (#126): the name-assignment now indexes proto_i[1] (a single
- # element), not the possibly length>1 proto_i. On an UNBROKEN within-cluster tie
- # -- here a CHARACTER y, so the numeric correlation tie-break is skipped and
- # proto_i stays length 2 -- the pre-fix code raised R's "number of items to
- # replace is not a multiple of replacement length" warning at the names<-
- # assignment (surfacing through print.cssr / summary.cssr / printCssDf). After
- # the fix NO warning fires, and the returned prototype is still the first tied
- # index (value unchanged; only the spurious warning is removed).
- B <- 10L; p <- 2L; n <- 8L
- X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
- colnames(X) <- paste0("V", 1:p)
- y <- letters[1:n] # non-numeric (character) response
- M <- matrix(0L, nrow = B, ncol = p)
- M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5,
- M[1:5, 2] <- 1L # forcing the (unbroken) tie-break path
- css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
- # No suppressWarnings here: the fix must make this call warning-free.
- testthat::expect_no_warning(
- res <- getSelectionPrototypes(css, list(c(1L, 2L))))
- testthat::expect_identical(unname(res), 1L) # first tied index, deterministic
- testthat::expect_identical(names(res), "V1") # name taken from proto_i[1] only
-})
+testthat::test_that("getSelectionPrototypes works", {
+ set.seed(67234)
+
+ data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
+
+ x <- data$X
+ y <- data$y
+
+ good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
+
+ css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters)
+
+ ret <- getSelectionPrototypes(css_results, selected_clusts=good_clusters)
+
+ testthat::expect_true(is.integer(ret))
+ testthat::expect_true(all(!is.na(ret)))
+ testthat::expect_equal(length(ret), length(good_clusters))
+ testthat::expect_equal(length(ret), length(unique(ret)))
+ for(i in 1:length(ret)){
+ testthat::expect_true(ret[i] %in% good_clusters[[i]])
+ # Find the largest selection proportion of any feature in cluster i
+ max_prop <- max(colMeans(css_results$feat_sel_mat[, good_clusters[[i]]]))
+ # Find the selection proportion of the identified prototype
+ proto_prop <- colMeans(css_results$feat_sel_mat)[ret[i]]
+ testthat::expect_equal(max_prop, proto_prop)
+ }
+
+ # Try with only one selected cluster (still should be in a list)
+
+ ret <- getSelectionPrototypes(css_results,
+ selected_clusts=list(red_cluster=1L:3L))
+
+ testthat::expect_true(is.integer(ret))
+ testthat::expect_true(!is.na(ret))
+ testthat::expect_equal(length(ret), 1)
+ testthat::expect_true(ret %in% 1L:3L)
+ # Find the largest selection proportion of any feature in the cluster
+ max_prop <- max(colMeans(css_results$feat_sel_mat[, 1L:3L]))
+ # Find the selection proportion of the identified prototype
+ proto_prop <- colMeans(css_results$feat_sel_mat)[ret]
+ testthat::expect_equal(max_prop, proto_prop)
+
+ ## Trying bad inputs
+
+ # Error contains quotation marks
+ testthat::expect_error(getSelectionPrototypes(x, good_clusters))
+
+ testthat::expect_error(getSelectionPrototypes(css_results, 1L:3L),
+ "is.list(selected_clusts) is not TRUE", fixed=TRUE)
+
+ # An empty selection (empty list of selected clusters) is valid post-#107:
+ # getSelectionPrototypes() returns an empty integer vector, no error (#120).
+ testthat::expect_identical(getSelectionPrototypes(css_results, list()),
+ integer(0))
+
+ testthat::expect_error(getSelectionPrototypes(css_results,
+ list(red_cluster=1L:3L,
+ green_cluster=4L:6L,
+ bad_cluster=integer())),
+ "all(lengths(selected_clusts) >= 1) is not TRUE",
+ fixed=TRUE)
+
+})
+
+testthat::test_that("getSelectionPrototypes handles a constant tied column without crashing (#68)", {
+ set.seed(680)
+ n <- 20L; p <- 4L
+ X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
+ X[, 2] <- 3.5 # feature 2 is a CONSTANT column
+ colnames(X) <- paste0("V", 1:p)
+ y <- X[, 1] + stats::rnorm(n) # y correlated with feature 1 (varying)
+ # feat_sel_mat: features 1 and 2 tie at selection proportion 0.5 (both
+ # "selected" in the same 5 of 10 subsamples), forcing the tie-break path.
+ B <- 10L
+ M <- matrix(0L, nrow = B, ncol = p)
+ M[1:5, 1] <- 1L
+ M[1:5, 2] <- 1L
+ css_results <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
+ # Pre-fix: cor(X[, c(1,2)], y) -> c(<corr>, NA) -> max NA -> stopifnot abort.
+ proto <- getSelectionPrototypes(css_results, selected_clusts = list(c(1L, 2L)))
+ testthat::expect_false(is.na(proto))
+ testthat::expect_identical(unname(proto), 1L) # the varying, y-correlated member
+
+ # All-constant tied cluster: must not crash, picks the first deterministically.
+ # (suppressWarnings: the names-assignment emits a pre-existing "number of items
+ # to replace..." warning when proto_i stays length>1; not introduced by this
+ # fix, unrelated to #68.)
+ X2 <- X; X2[, 3] <- 2.0; X2[, 4] <- 9.0
+ M2 <- matrix(0L, nrow = B, ncol = p); M2[1:5, 3] <- 1L; M2[1:5, 4] <- 1L
+ css2 <- structure(list(X = X2, y = y, feat_sel_mat = M2), class = "cssr")
+ proto2 <- suppressWarnings(
+ getSelectionPrototypes(css2, selected_clusts = list(c(3L, 4L))))
+ testthat::expect_identical(unname(proto2), 3L)
+})
+
+testthat::test_that("getSelectionPrototypes skips the correlation tie-break for non-numeric y (#128)", {
+ # css() accepts a non-numeric y (response validation is delegated to fitfun),
+ # so getSelectionPrototypes must NOT call cor() -- which requires a numeric y --
+ # when breaking a selection-proportion tie. Hand-build a cssr object with a
+ # CHARACTER y and a feat_sel_mat in which members 1 and 2 tie (equal column
+ # means) so the tie block IS entered (length(proto_i) > 1). Without the
+ # is.numeric(y) guard, cor(X[, 1:2], <character y>) would error; the guard skips
+ # it and the first tied index is returned deterministically.
+ B <- 10L; p <- 2L; n <- 8L
+ X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
+ colnames(X) <- paste0("V", 1:p)
+ y <- letters[1:n] # non-numeric (character) response
+ M <- matrix(0L, nrow = B, ncol = p)
+ M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5,
+ M[1:5, 2] <- 1L # forcing the tie-break path
+ css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
+ # suppressWarnings: an unbroken length-2 tie triggers a benign R "number of
+ # items to replace" warning at the names-assignment (it fires for ANY persisted
+ # tie, incl. the numeric #68 case) that would otherwise fail testthat edition 3.
+ res <- suppressWarnings(getSelectionPrototypes(css, list(c(1L, 2L))))
+ testthat::expect_identical(unname(res), 1L) # first tied index, deterministic
+})
+
+testthat::test_that("getSelectionPrototypes emits no warning on an unbroken tie (#126)", {
+ # Item-5 regression (#126): the name-assignment now indexes proto_i[1] (a single
+ # element), not the possibly length>1 proto_i. On an UNBROKEN within-cluster tie
+ # -- here a CHARACTER y, so the numeric correlation tie-break is skipped and
+ # proto_i stays length 2 -- the pre-fix code raised R's "number of items to
+ # replace is not a multiple of replacement length" warning at the names<-
+ # assignment (surfacing through print.cssr / summary.cssr / printCssDf). After
+ # the fix NO warning fires, and the returned prototype is still the first tied
+ # index (value unchanged; only the spurious warning is removed).
+ B <- 10L; p <- 2L; n <- 8L
+ X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
+ colnames(X) <- paste0("V", 1:p)
+ y <- letters[1:n] # non-numeric (character) response
+ M <- matrix(0L, nrow = B, ncol = p)
+ M[1:5, 1] <- 1L # features 1 and 2 tie at proportion 0.5,
+ M[1:5, 2] <- 1L # forcing the (unbroken) tie-break path
+ css <- structure(list(X = X, y = y, feat_sel_mat = M), class = "cssr")
+ # No suppressWarnings here: the fix must make this call warning-free.
+ testthat::expect_no_warning(
+ res <- getSelectionPrototypes(css, list(c(1L, 2L))))
+ testthat::expect_identical(unname(res), 1L) # first tied index, deterministic
+ testthat::expect_identical(names(res), "V1") # name taken from proto_i[1] only
+})
## Test passed with 17 successes.
## Test passed with 3 successes.
## Test passed with 1 success.
## Test passed with 3 successes.
Tests for printCssDf():
-testthat::test_that("printCssDf works", {
- set.seed(67234)
-
- data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
-
- x <- data$X
- y <- data$y
-
- good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
-
- css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10)
-
- ret <- printCssDf(css_results)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
- "ClustSelProp", "ClustSize"))
-
- # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
- testthat::expect_equal(nrow(ret), 7)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_true(all(names(good_clusters) %in% ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoNum"] %in% 1L:3L)
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoNum"] %in% 4L:6L)
- other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
- testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
- testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
- length(unique(ret[other_rows, "ClustProtoNum"])))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
- testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
- testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
- testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
-
- # Try again naming features
-
- x_named <- x
- colnames(x_named) <- LETTERS[1:11]
-
- css_results_name_feats <- css(X=x_named, y=y, lambda=0.01,
- clusters=good_clusters, B=10)
-
- ret <- printCssDf(css_results_name_feats)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoName",
- "ClustProtoNum", "ClustSelProp",
- "ClustSize"))
-
- # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
- testthat::expect_equal(nrow(ret), 7)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_true(all(names(good_clusters) %in% ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.character(ret$ClustProtoName))
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoName"] %in% LETTERS[1:3])
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoName"] %in% LETTERS[4:6])
- other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
- testthat::expect_true(all(ret[other_rows, "ClustProtoName"] %in% LETTERS[7:11]))
- testthat::expect_true(length(ret[other_rows, "ClustProtoName"]) ==
- length(unique(ret[other_rows, "ClustProtoName"])))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoNum"] %in% 1L:3L)
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoNum"] %in% 4L:6L)
- testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
- testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
- length(unique(ret[other_rows, "ClustProtoNum"])))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
- testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
- testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
- testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
-
- # Unnamed clusters
-
- unnamed_clusters <- list(1:3, 4:6)
-
- css_results_unnamed <- css(X=x, y=y, lambda=0.01, clusters=unnamed_clusters,
- B=10)
-
- ret <- printCssDf(css_results_unnamed)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
- "ClustSelProp", "ClustSize"))
-
- # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
- testthat::expect_equal(nrow(ret), 7)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
-
- # Try other settings for cutoff, min_num_clusts, max_num_clusts, etc.
-
- ret <- printCssDf(css_results, max_num_clusts=3)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
- "ClustSelProp", "ClustSize"))
-
- testthat::expect_true(nrow(ret) <= 3)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
- other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
- testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
- testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
- length(unique(ret[other_rows, "ClustProtoNum"])))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
- testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
-
- if("red_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoNum"] %in% 1L:3L)
- testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
- }
-
- if("green_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoNum"] %in% 4L:6L)
- testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
- }
-
- ret <- printCssDf(css_results, min_num_clusts=2, cutoff=1)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
- "ClustSelProp", "ClustSize"))
-
- # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
- testthat::expect_true(nrow(ret) >= 2)
- testthat::expect_true(nrow(ret) <= 7)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
- other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
- testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
- testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
- length(unique(ret[other_rows, "ClustProtoNum"])))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
- testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
-
- if("red_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoNum"] %in% 1L:3L)
- testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
- }
-
- if("green_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoNum"] %in% 4L:6L)
- testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
- }
-
- #
- ret <- printCssDf(css_results, cutoff=1)
-
- testthat::expect_true(is.data.frame(ret))
- testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
- "ClustSelProp", "ClustSize"))
-
- testthat::expect_true(nrow(ret) >= 1)
- testthat::expect_true(nrow(ret) <= 7)
-
- testthat::expect_true(is.character(ret$ClustName))
- testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
-
- testthat::expect_true(is.integer(ret$ClustProtoNum))
- other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
- testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
- testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
- length(unique(ret[other_rows, "ClustProtoNum"])))
-
- testthat::expect_true(is.numeric(ret$ClustSelProp))
- testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
- decreasing=TRUE))
-
- testthat::expect_true(is.integer(ret$ClustSize))
- testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
-
- if("red_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="red_cluster",
- "ClustProtoNum"] %in% 1L:3L)
- testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
- }
-
- if("green_cluster" %in% ret$ClustName){
- testthat::expect_true(ret[ret$ClustName=="green_cluster",
- "ClustProtoNum"] %in% 4L:6L)
- testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
- }
-
- ## Trying bad inputs
-
- # Error has quotation marks in it
- testthat::expect_error(printCssDf("css_results"))
-
- testthat::expect_error(printCssDf(css_results, cutoff=-.1),
- "cutoff >= 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(printCssDf(css_results, min_num_clusts=3.2),
- "min_num_clusts == round(min_num_clusts) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(printCssDf(css_results, max_num_clusts="5"),
- "is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
- fixed=TRUE)
-})
+testthat::test_that("printCssDf works", {
+ set.seed(67234)
+
+ data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
+
+ x <- data$X
+ y <- data$y
+
+ good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
+
+ css_results <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10)
+
+ ret <- printCssDf(css_results)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
+ "ClustSelProp", "ClustSize"))
+
+ # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
+ testthat::expect_equal(nrow(ret), 7)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_true(all(names(good_clusters) %in% ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoNum"] %in% 1L:3L)
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoNum"] %in% 4L:6L)
+ other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
+ testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
+ length(unique(ret[other_rows, "ClustProtoNum"])))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+ testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
+ testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
+ testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
+
+ # Try again naming features
+
+ x_named <- x
+ colnames(x_named) <- LETTERS[1:11]
+
+ css_results_name_feats <- css(X=x_named, y=y, lambda=0.01,
+ clusters=good_clusters, B=10)
+
+ ret <- printCssDf(css_results_name_feats)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoName",
+ "ClustProtoNum", "ClustSelProp",
+ "ClustSize"))
+
+ # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
+ testthat::expect_equal(nrow(ret), 7)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_true(all(names(good_clusters) %in% ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.character(ret$ClustProtoName))
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoName"] %in% LETTERS[1:3])
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoName"] %in% LETTERS[4:6])
+ other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
+ testthat::expect_true(all(ret[other_rows, "ClustProtoName"] %in% LETTERS[7:11]))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoName"]) ==
+ length(unique(ret[other_rows, "ClustProtoName"])))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoNum"] %in% 1L:3L)
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoNum"] %in% 4L:6L)
+ testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
+ length(unique(ret[other_rows, "ClustProtoNum"])))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+ testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
+ testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
+ testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
+
+ # Unnamed clusters
+
+ unnamed_clusters <- list(1:3, 4:6)
+
+ css_results_unnamed <- css(X=x, y=y, lambda=0.01, clusters=unnamed_clusters,
+ B=10)
+
+ ret <- printCssDf(css_results_unnamed)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
+ "ClustSelProp", "ClustSize"))
+
+ # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
+ testthat::expect_equal(nrow(ret), 7)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+
+ # Try other settings for cutoff, min_num_clusts, max_num_clusts, etc.
+
+ ret <- printCssDf(css_results, max_num_clusts=3)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
+ "ClustSelProp", "ClustSize"))
+
+ testthat::expect_true(nrow(ret) <= 3)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+ other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
+ testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
+ length(unique(ret[other_rows, "ClustProtoNum"])))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+ testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
+
+ if("red_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoNum"] %in% 1L:3L)
+ testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
+ }
+
+ if("green_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoNum"] %in% 4L:6L)
+ testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
+ }
+
+ ret <- printCssDf(css_results, min_num_clusts=2, cutoff=1)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
+ "ClustSelProp", "ClustSize"))
+
+ # Total number of clusters is 11 - (3 - 1) - (3 - 1) = 7
+ testthat::expect_true(nrow(ret) >= 2)
+ testthat::expect_true(nrow(ret) <= 7)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+ other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
+ testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
+ length(unique(ret[other_rows, "ClustProtoNum"])))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+ testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
+
+ if("red_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoNum"] %in% 1L:3L)
+ testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
+ }
+
+ if("green_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoNum"] %in% 4L:6L)
+ testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
+ }
+
+ #
+ ret <- printCssDf(css_results, cutoff=1)
+
+ testthat::expect_true(is.data.frame(ret))
+ testthat::expect_identical(colnames(ret), c("ClustName", "ClustProtoNum",
+ "ClustSelProp", "ClustSize"))
+
+ testthat::expect_true(nrow(ret) >= 1)
+ testthat::expect_true(nrow(ret) <= 7)
+
+ testthat::expect_true(is.character(ret$ClustName))
+ testthat::expect_equal(length(ret$ClustName), length(unique(ret$ClustName)))
+
+ testthat::expect_true(is.integer(ret$ClustProtoNum))
+ other_rows <- !(ret$ClustName %in% c("red_cluster", "green_cluster"))
+ testthat::expect_true(all(ret[other_rows, "ClustProtoNum"] %in% 7L:11L))
+ testthat::expect_true(length(ret[other_rows, "ClustProtoNum"]) ==
+ length(unique(ret[other_rows, "ClustProtoNum"])))
+
+ testthat::expect_true(is.numeric(ret$ClustSelProp))
+ testthat::expect_identical(ret$ClustSelProp, sort(ret$ClustSelProp,
+ decreasing=TRUE))
+
+ testthat::expect_true(is.integer(ret$ClustSize))
+ testthat::expect_true(all(ret[other_rows, "ClustSize"] == 1))
+
+ if("red_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="red_cluster",
+ "ClustProtoNum"] %in% 1L:3L)
+ testthat::expect_equal(ret[ret$ClustName=="red_cluster", "ClustSize"], 3)
+ }
+
+ if("green_cluster" %in% ret$ClustName){
+ testthat::expect_true(ret[ret$ClustName=="green_cluster",
+ "ClustProtoNum"] %in% 4L:6L)
+ testthat::expect_equal(ret[ret$ClustName=="green_cluster", "ClustSize"], 3)
+ }
+
+ ## Trying bad inputs
+
+ # Error has quotation marks in it
+ testthat::expect_error(printCssDf("css_results"))
+
+ testthat::expect_error(printCssDf(css_results, cutoff=-.1),
+ "cutoff >= 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(printCssDf(css_results, min_num_clusts=3.2),
+ "min_num_clusts == round(min_num_clusts) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(printCssDf(css_results, max_num_clusts="5"),
+ "is.numeric(max_num_clusts) | is.integer(max_num_clusts) is not TRUE",
+ fixed=TRUE)
+})
## Test passed with 98 successes.
Tests for print.cssr() (and a minimal-B smoke test for css()):
-testthat::test_that("print.cssr 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)
-
- # print() dispatches to print.cssr, which returns its argument invisibly (the
- # standard print-method convention; see print.cssr's @return / #16).
- testthat::expect_invisible(print(css_res))
- ret <- print(css_res)
- testthat::expect_identical(ret, css_res)
-
- # It prints the printCssDf summary table (column headers included).
- testthat::expect_output(print(css_res), "ClustName")
- testthat::expect_output(print(css_res), "ClustSize")
-
- # max_num_clusts routes through to printCssDf (at most that many cluster rows).
- out_all <- utils::capture.output(print(css_res))
- out_one <- utils::capture.output(print(css_res, max_num_clusts=1))
- testthat::expect_true(length(out_one) <= length(out_all))
-})
-
-testthat::test_that("css runs with B = 1 (minimal subsampling)", {
- 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)
-
- # B = 1 is allowed (checkB requires only B > 0) but warns that small B is poor.
- testthat::expect_warning(
- css_b1 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 1),
- "Small values of B may lead to poor results.", fixed=TRUE)
- testthat::expect_true(inherits(css_b1, "cssr"))
-
- # The minimal-B object is still well-formed downstream.
- sel <- getCssSelections(css_b1)
- testthat::expect_identical(names(sel),
- c("selected_clusts", "selected_feats", "weights"))
-})
+testthat::test_that("print.cssr 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)
+
+ # print() dispatches to print.cssr, which returns its argument invisibly (the
+ # standard print-method convention; see print.cssr's @return / #16).
+ testthat::expect_invisible(print(css_res))
+ ret <- print(css_res)
+ testthat::expect_identical(ret, css_res)
+
+ # It prints the printCssDf summary table (column headers included).
+ testthat::expect_output(print(css_res), "ClustName")
+ testthat::expect_output(print(css_res), "ClustSize")
+
+ # max_num_clusts routes through to printCssDf (at most that many cluster rows).
+ out_all <- utils::capture.output(print(css_res))
+ out_one <- utils::capture.output(print(css_res, max_num_clusts=1))
+ testthat::expect_true(length(out_one) <= length(out_all))
+})
+
+testthat::test_that("css runs with B = 1 (minimal subsampling)", {
+ 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)
+
+ # B = 1 is allowed (checkB requires only B > 0) but warns that small B is poor.
+ testthat::expect_warning(
+ css_b1 <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B = 1),
+ "Small values of B may lead to poor results.", fixed=TRUE)
+ testthat::expect_true(inherits(css_b1, "cssr"))
+
+ # The minimal-B object is still well-formed downstream.
+ sel <- getCssSelections(css_b1)
+ testthat::expect_identical(names(sel),
+ c("selected_clusts", "selected_feats", "weights"))
+})
## ClustName ClustProtoNum ClustSelProp ClustSize
## 1 banana 4 1.00 2
## 2 cantaloupe 5 0.80 1
@@ -2507,126 +2507,126 @@
## Test passed with 5 successes.
## Test passed with 3 successes.
Tests for selected() / selected.cssr():
-testthat::test_that("selected.cssr returns clusters and features", {
- 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)
-
- ref <- getCssSelections(css_res)
-
- # type = "clusters" (the default): a named list of integer vectors, identical
- # to getCssSelections()$selected_clusts at the same parameters.
- clusts <- selected(css_res)
- testthat::expect_true(is.list(clusts))
- testthat::expect_identical(clusts, ref$selected_clusts)
- testthat::expect_identical(selected(css_res, type="clusters"),
- ref$selected_clusts)
-
- # type = "features": a flat integer vector, identical to
- # getCssSelections()$selected_feats.
- feats <- selected(css_res, type="features")
- testthat::expect_true(is.integer(feats))
- testthat::expect_identical(feats, ref$selected_feats)
-
- # S3 dispatch: selected(obj) reaches selected.cssr().
- testthat::expect_identical(selected(css_res), selected.cssr(css_res))
-
- # Consistency with getCssSelections() at a nondefault cutoff and weighting
- # (features path).
- ref2 <- getCssSelections(css_res, weighting="simple_avg", cutoff=0.3)
- testthat::expect_identical(
- selected(css_res, type="features", weighting="simple_avg", cutoff=0.3),
- ref2$selected_feats)
-
- # Invalid inputs are rejected via the reused checks (checkCutoff /
- # checkWeighting), same messages as getCssSelections().
- testthat::expect_error(selected(css_res, cutoff=-0.5),
- "cutoff >= 0 is not TRUE", fixed=TRUE)
- testthat::expect_error(selected(css_res, weighting="spasre"),
- "Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
- fixed=TRUE)
-})
-
-testthat::test_that("selected(type='clusters') is invariant to weighting", {
- 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)
-
- # weighting only affects individual-feature weights, never which clusters are
- # selected: the type = "clusters" output is identical across weighting values.
- sparse <- selected(css_res, type="clusters", weighting="sparse", cutoff=0.2)
- wavg <- selected(css_res, type="clusters", weighting="weighted_avg",
- cutoff=0.2)
- savg <- selected(css_res, type="clusters", weighting="simple_avg",
- cutoff=0.2)
- testthat::expect_identical(sparse, wavg)
- testthat::expect_identical(sparse, savg)
-
- # By contrast the features path CAN depend on weighting: "simple_avg" returns
- # every member of the selected clusters, so at least as many as "sparse".
- feats_sparse <- selected(css_res, type="features", weighting="sparse",
- cutoff=0.2)
- feats_savg <- selected(css_res, type="features", weighting="simple_avg",
- cutoff=0.2)
- testthat::expect_true(length(feats_savg) >= length(feats_sparse))
-})
+testthat::test_that("selected.cssr returns clusters and features", {
+ 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)
+
+ ref <- getCssSelections(css_res)
+
+ # type = "clusters" (the default): a named list of integer vectors, identical
+ # to getCssSelections()$selected_clusts at the same parameters.
+ clusts <- selected(css_res)
+ testthat::expect_true(is.list(clusts))
+ testthat::expect_identical(clusts, ref$selected_clusts)
+ testthat::expect_identical(selected(css_res, type="clusters"),
+ ref$selected_clusts)
+
+ # type = "features": a flat integer vector, identical to
+ # getCssSelections()$selected_feats.
+ feats <- selected(css_res, type="features")
+ testthat::expect_true(is.integer(feats))
+ testthat::expect_identical(feats, ref$selected_feats)
+
+ # S3 dispatch: selected(obj) reaches selected.cssr().
+ testthat::expect_identical(selected(css_res), selected.cssr(css_res))
+
+ # Consistency with getCssSelections() at a nondefault cutoff and weighting
+ # (features path).
+ ref2 <- getCssSelections(css_res, weighting="simple_avg", cutoff=0.3)
+ testthat::expect_identical(
+ selected(css_res, type="features", weighting="simple_avg", cutoff=0.3),
+ ref2$selected_feats)
+
+ # Invalid inputs are rejected via the reused checks (checkCutoff /
+ # checkWeighting), same messages as getCssSelections().
+ testthat::expect_error(selected(css_res, cutoff=-0.5),
+ "cutoff >= 0 is not TRUE", fixed=TRUE)
+ testthat::expect_error(selected(css_res, weighting="spasre"),
+ "Weighting must be a character and one of sparse, simple_avg, or weighted_avg",
+ fixed=TRUE)
+})
+
+testthat::test_that("selected(type='clusters') is invariant to weighting", {
+ 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)
+
+ # weighting only affects individual-feature weights, never which clusters are
+ # selected: the type = "clusters" output is identical across weighting values.
+ sparse <- selected(css_res, type="clusters", weighting="sparse", cutoff=0.2)
+ wavg <- selected(css_res, type="clusters", weighting="weighted_avg",
+ cutoff=0.2)
+ savg <- selected(css_res, type="clusters", weighting="simple_avg",
+ cutoff=0.2)
+ testthat::expect_identical(sparse, wavg)
+ testthat::expect_identical(sparse, savg)
+
+ # By contrast the features path CAN depend on weighting: "simple_avg" returns
+ # every member of the selected clusters, so at least as many as "sparse".
+ feats_sparse <- selected(css_res, type="features", weighting="sparse",
+ cutoff=0.2)
+ feats_savg <- selected(css_res, type="features", weighting="simple_avg",
+ cutoff=0.2)
+ testthat::expect_true(length(feats_savg) >= length(feats_sparse))
+})
## Test passed with 9 successes.
## Test passed with 3 successes.
Tests for summary.cssr() / print.summary.cssr():
-testthat::test_that("summary.cssr summarizes clusters, sizes, and header counts", {
- set.seed(67234)
- data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
- x <- data$X
- y <- data$y
- good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
- css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10)
-
- smry <- summary(css_res)
- testthat::expect_true(inherits(smry, "summary.cssr"))
-
- ref <- getCssSelections(css_res)
- ref_df <- printCssDf(css_res)
-
- # Header counts are consistent with getCssSelections().
- testthat::expect_equal(smry$n_selected_clusts, length(ref$selected_clusts))
- testthat::expect_equal(smry$n_selected_feats, length(ref$selected_feats))
- testthat::expect_equal(smry$cutoff, 0)
-
- # The per-cluster table IS printCssDf()'s data.frame (Theta-hat = ClustSelProp,
- # plus ClustSize), so clusters / proportions / sizes all match.
- testthat::expect_identical(smry$table, ref_df)
- testthat::expect_equal(nrow(smry$table), 7)
- testthat::expect_equal(smry$n_selected_clusts, nrow(smry$table))
- testthat::expect_true(all(c("ClustName", "ClustSelProp", "ClustSize") %in%
- colnames(smry$table)))
- testthat::expect_equal(smry$table[smry$table$ClustName=="red_cluster",
- "ClustSize"], 3)
- testthat::expect_equal(smry$table[smry$table$ClustName=="green_cluster",
- "ClustSize"], 3)
-
- # PFER placeholder present (to be filled in by #87).
- testthat::expect_true("pfer" %in% names(smry))
- testthat::expect_true(is.na(smry$pfer))
-
- # print.summary.cssr runs, prints the header + table, returns x invisibly.
- testthat::expect_invisible(print(smry))
- ret <- print(smry)
- testthat::expect_identical(ret, smry)
- testthat::expect_output(print(smry), "selected at cutoff")
- testthat::expect_output(print(smry), "ClustName")
-
- # S3 dispatch: summary(obj) reaches summary.cssr().
- testthat::expect_identical(summary(css_res), summary.cssr(css_res))
-
- # Invalid cutoff rejected via the reused check.
- testthat::expect_error(summary(css_res, cutoff=1.5),
- "cutoff <= 1 is not TRUE", fixed=TRUE)
-})
+testthat::test_that("summary.cssr summarizes clusters, sizes, and header counts", {
+ set.seed(67234)
+ data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=10^(-6))
+ x <- data$X
+ y <- data$y
+ good_clusters <- list(red_cluster=1L:3L, green_cluster=4L:6L)
+ css_res <- css(X=x, y=y, lambda=0.01, clusters=good_clusters, B=10)
+
+ smry <- summary(css_res)
+ testthat::expect_true(inherits(smry, "summary.cssr"))
+
+ ref <- getCssSelections(css_res)
+ ref_df <- printCssDf(css_res)
+
+ # Header counts are consistent with getCssSelections().
+ testthat::expect_equal(smry$n_selected_clusts, length(ref$selected_clusts))
+ testthat::expect_equal(smry$n_selected_feats, length(ref$selected_feats))
+ testthat::expect_equal(smry$cutoff, 0)
+
+ # The per-cluster table IS printCssDf()'s data.frame (Theta-hat = ClustSelProp,
+ # plus ClustSize), so clusters / proportions / sizes all match.
+ testthat::expect_identical(smry$table, ref_df)
+ testthat::expect_equal(nrow(smry$table), 7)
+ testthat::expect_equal(smry$n_selected_clusts, nrow(smry$table))
+ testthat::expect_true(all(c("ClustName", "ClustSelProp", "ClustSize") %in%
+ colnames(smry$table)))
+ testthat::expect_equal(smry$table[smry$table$ClustName=="red_cluster",
+ "ClustSize"], 3)
+ testthat::expect_equal(smry$table[smry$table$ClustName=="green_cluster",
+ "ClustSize"], 3)
+
+ # PFER placeholder present (to be filled in by #87).
+ testthat::expect_true("pfer" %in% names(smry))
+ testthat::expect_true(is.na(smry$pfer))
+
+ # print.summary.cssr runs, prints the header + table, returns x invisibly.
+ testthat::expect_invisible(print(smry))
+ ret <- print(smry)
+ testthat::expect_identical(ret, smry)
+ testthat::expect_output(print(smry), "selected at cutoff")
+ testthat::expect_output(print(smry), "ClustName")
+
+ # S3 dispatch: summary(obj) reaches summary.cssr().
+ testthat::expect_identical(summary(css_res), summary.cssr(css_res))
+
+ # Invalid cutoff rejected via the reused check.
+ testthat::expect_error(summary(css_res, cutoff=1.5),
+ "cutoff <= 1 is not TRUE", fixed=TRUE)
+})
## Cluster stability selection summary
## 7 clusters / 7 features selected at cutoff 0
##
@@ -2661,83 +2661,83 @@
integer vector, respectively – via an early return before the nrow >= 1 /
n_selected_clusts >= 1 guards, rather than tripping those assertions. The
block also covers the higher-level selected() and a zero-row summary.cssr().
-testthat::test_that("selected() and summary() handle an empty selection", {
- # Same empty-producing fixture as the getCssSelections #107 test: fixed seed,
- # all-singleton clusters, and a large lambda so the base lasso selects almost
- # nothing; cutoff = 1 with min_num_clusts = 0 then selects no cluster.
- 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))
-
- # selected(): a clean empty list / empty integer vector, no error.
- empty_clusts <- selected(css_res, cutoff=1, min_num_clusts=0)
- testthat::expect_true(is.list(empty_clusts))
- testthat::expect_length(empty_clusts, 0)
- empty_feats <- selected(css_res, type="features", cutoff=1, min_num_clusts=0)
- testthat::expect_true(is.integer(empty_feats))
- testthat::expect_length(empty_feats, 0)
-
- # summary(): a well-formed zero-row summary (table NULL, "0 clusters" header),
- # NOT an opaque stopifnot() failure from printCssDf/getSelectionPrototypes.
- smry <- summary(css_res, cutoff=1, min_num_clusts=0)
- testthat::expect_true(inherits(smry, "summary.cssr"))
- testthat::expect_equal(smry$n_selected_clusts, 0)
- testthat::expect_equal(smry$n_selected_feats, 0)
- testthat::expect_true(is.null(smry$table))
-
- # print still works and reports 0 clusters / 0 features.
- testthat::expect_invisible(print(smry))
- testthat::expect_output(print(smry), "0 clusters / 0 features")
-
- # printCssDf() (#120): an empty selection returns a well-formed zero-row
- # data.frame with the SAME columns as a non-empty printCssDf() on the same
- # object, rather than tripping stopifnot(nrow >= 1). Unnamed X (this fixture)
- # -> 4 columns, no ClustProtoName.
- empty_df <- printCssDf(css_res, cutoff=1, min_num_clusts=0)
- testthat::expect_true(is.data.frame(empty_df))
- testthat::expect_equal(nrow(empty_df), 0)
- testthat::expect_equal(ncol(empty_df), 4)
- nonempty_df <- printCssDf(css_res, cutoff=0)
- testthat::expect_true(nrow(nonempty_df) >= 1)
- # The invariant that matters: empty and non-empty share the same column set.
- testthat::expect_identical(colnames(empty_df), colnames(nonempty_df))
- testthat::expect_identical(
- colnames(empty_df),
- c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize"))
- # Correct 0-length column types.
- testthat::expect_true(is.character(empty_df$ClustName))
- testthat::expect_true(is.integer(empty_df$ClustProtoNum))
- testthat::expect_true(is.numeric(empty_df$ClustSelProp))
- testthat::expect_true(is.integer(empty_df$ClustSize))
-
- # Named X -> the 5-column path (adds ClustProtoName). Same data + column names,
- # so the selection is still empty at cutoff = 1 with min_num_clusts = 0.
- x_named <- x
- colnames(x_named) <- paste0("V", seq_len(ncol(x_named)))
- css_named <- css(X=x_named, y=y, lambda=0.5, clusters=list(), B=B)
- empty_named_df <- printCssDf(css_named, cutoff=1, min_num_clusts=0)
- testthat::expect_true(is.data.frame(empty_named_df))
- testthat::expect_equal(nrow(empty_named_df), 0)
- testthat::expect_equal(ncol(empty_named_df), 5)
- testthat::expect_true("ClustProtoName" %in% colnames(empty_named_df))
- testthat::expect_identical(colnames(empty_named_df),
- colnames(printCssDf(css_named, cutoff=0)))
-
- # getSelectionPrototypes() on an empty list of clusters -> integer(0) (#120).
- testthat::expect_identical(getSelectionPrototypes(css_res, list()),
- integer(0))
-
- # print.cssr() (#120): prints a "(no clusters selected ...)" message instead
- # of a table, does not error, and returns the cssr object invisibly unchanged.
- testthat::expect_output(
- ret <- print(css_res, cutoff=1, min_num_clusts=0),
- "no clusters selected")
- testthat::expect_identical(ret, css_res)
- testthat::expect_invisible(print(css_res, cutoff=1, min_num_clusts=0))
-})
+testthat::test_that("selected() and summary() handle an empty selection", {
+ # Same empty-producing fixture as the getCssSelections #107 test: fixed seed,
+ # all-singleton clusters, and a large lambda so the base lasso selects almost
+ # nothing; cutoff = 1 with min_num_clusts = 0 then selects no cluster.
+ 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))
+
+ # selected(): a clean empty list / empty integer vector, no error.
+ empty_clusts <- selected(css_res, cutoff=1, min_num_clusts=0)
+ testthat::expect_true(is.list(empty_clusts))
+ testthat::expect_length(empty_clusts, 0)
+ empty_feats <- selected(css_res, type="features", cutoff=1, min_num_clusts=0)
+ testthat::expect_true(is.integer(empty_feats))
+ testthat::expect_length(empty_feats, 0)
+
+ # summary(): a well-formed zero-row summary (table NULL, "0 clusters" header),
+ # NOT an opaque stopifnot() failure from printCssDf/getSelectionPrototypes.
+ smry <- summary(css_res, cutoff=1, min_num_clusts=0)
+ testthat::expect_true(inherits(smry, "summary.cssr"))
+ testthat::expect_equal(smry$n_selected_clusts, 0)
+ testthat::expect_equal(smry$n_selected_feats, 0)
+ testthat::expect_true(is.null(smry$table))
+
+ # print still works and reports 0 clusters / 0 features.
+ testthat::expect_invisible(print(smry))
+ testthat::expect_output(print(smry), "0 clusters / 0 features")
+
+ # printCssDf() (#120): an empty selection returns a well-formed zero-row
+ # data.frame with the SAME columns as a non-empty printCssDf() on the same
+ # object, rather than tripping stopifnot(nrow >= 1). Unnamed X (this fixture)
+ # -> 4 columns, no ClustProtoName.
+ empty_df <- printCssDf(css_res, cutoff=1, min_num_clusts=0)
+ testthat::expect_true(is.data.frame(empty_df))
+ testthat::expect_equal(nrow(empty_df), 0)
+ testthat::expect_equal(ncol(empty_df), 4)
+ nonempty_df <- printCssDf(css_res, cutoff=0)
+ testthat::expect_true(nrow(nonempty_df) >= 1)
+ # The invariant that matters: empty and non-empty share the same column set.
+ testthat::expect_identical(colnames(empty_df), colnames(nonempty_df))
+ testthat::expect_identical(
+ colnames(empty_df),
+ c("ClustName", "ClustProtoNum", "ClustSelProp", "ClustSize"))
+ # Correct 0-length column types.
+ testthat::expect_true(is.character(empty_df$ClustName))
+ testthat::expect_true(is.integer(empty_df$ClustProtoNum))
+ testthat::expect_true(is.numeric(empty_df$ClustSelProp))
+ testthat::expect_true(is.integer(empty_df$ClustSize))
+
+ # Named X -> the 5-column path (adds ClustProtoName). Same data + column names,
+ # so the selection is still empty at cutoff = 1 with min_num_clusts = 0.
+ x_named <- x
+ colnames(x_named) <- paste0("V", seq_len(ncol(x_named)))
+ css_named <- css(X=x_named, y=y, lambda=0.5, clusters=list(), B=B)
+ empty_named_df <- printCssDf(css_named, cutoff=1, min_num_clusts=0)
+ testthat::expect_true(is.data.frame(empty_named_df))
+ testthat::expect_equal(nrow(empty_named_df), 0)
+ testthat::expect_equal(ncol(empty_named_df), 5)
+ testthat::expect_true("ClustProtoName" %in% colnames(empty_named_df))
+ testthat::expect_identical(colnames(empty_named_df),
+ colnames(printCssDf(css_named, cutoff=0)))
+
+ # getSelectionPrototypes() on an empty list of clusters -> integer(0) (#120).
+ testthat::expect_identical(getSelectionPrototypes(css_res, list()),
+ integer(0))
+
+ # print.cssr() (#120): prints a "(no clusters selected ...)" message instead
+ # of a table, does not error, and returns the cssr object invisibly unchanged.
+ testthat::expect_output(
+ ret <- print(css_res, cutoff=1, min_num_clusts=0),
+ "no clusters selected")
+ testthat::expect_identical(ret, css_res)
+ testthat::expect_invisible(print(css_res, cutoff=1, min_num_clusts=0))
+})
## Cluster stability selection summary
## 0 clusters / 0 features selected at cutoff 1
## (no clusters selected at this cutoff)
@@ -2751,156 +2751,156 @@
index-based feature highlight for an unnamed X (the B2 guard), ...
passthrough to barplot() without a duplicate-argument crash (the B1 guard),
and the empty-selection and single-cluster edge cases.
-testthat::test_that("plot.cssr draws cluster proportions and returns them sorted", {
- # Named X so the feature matrix (tested below) carries feature names.
- set.seed(26717)
- x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
- colnames(x) <- paste0("V", seq_len(ncol(x)))
- 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)
-
- grDevices::pdf(NULL) # draw to a null device (no file, no window)
-
- # (a) Clusters (default): runs without error and invisibly returns the sorted
- # named cluster selection proportions (a deterministic proof of the return).
- testthat::expect_invisible(plot(css_res))
- ret <- plot(css_res)
- testthat::expect_equal(ret,
- sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE))
- testthat::expect_false(is.null(names(ret))) # cluster names guaranteed
-
- # (b) Features, NAMED X: returns the sorted NAMED feature selection
- # proportions, and the (index-based) highlight matches getCssSelections().
- ret_f <- plot(css_res, type="features")
- props_f <- colMeans(css_res$feat_sel_mat)
- testthat::expect_equal(ret_f, sort(props_f, decreasing=TRUE))
- testthat::expect_identical(names(ret_f),
- paste0("V", order(props_f, decreasing=TRUE))) # named + correctly ordered
- sel_f <- getCssSelections(css_res, weighting="sparse")
- ord <- order(props_f, decreasing=TRUE)
- is_sel <- (seq_along(props_f) %in% as.integer(sel_f$selected_feats))[ord]
- testthat::expect_equal(sum(is_sel), length(sel_f$selected_feats))
- testthat::expect_setequal(ord[is_sel], as.integer(sel_f$selected_feats))
-
- grDevices::dev.off()
-})
-
-testthat::test_that("plot.cssr feature highlight is index-based for unnamed X (B2)", {
- # genClusteredData returns X with NULL colnames -> feat_sel_mat is UNNAMED.
- # A name-based feature highlight would silently be all-FALSE; the method uses
- # an INDEX-based highlight, which must still be non-empty. This is the B2
- # regression proof.
- set.seed(721)
- dat <- genClusteredData(n=60, p=11, k_unclustered=2, cluster_size=4,
- n_clusters=1, snr=3)
- clusters <- list(cluster1=1:4)
- css_res <- suppressWarnings(css(X=dat$X, y=dat$y, lambda=0.01,
- clusters=clusters, B=10))
-
- # Precondition for the B2 guard: the feature matrix really is unnamed.
- testthat::expect_null(colnames(css_res$feat_sel_mat))
-
- grDevices::pdf(NULL)
-
- props <- colMeans(css_res$feat_sel_mat)
- ret <- plot(css_res, type="features", cutoff=0.3)
- # Returns the plain (unnamed) sorted colMeans regardless of the cutoff.
- testthat::expect_equal(ret, sort(props, decreasing=TRUE))
- testthat::expect_null(names(ret))
-
- # Re-derive the highlight exactly as plot.cssr does: INDEX-based.
- sel <- getCssSelections(css_res, weighting="sparse", cutoff=0.3)
- testthat::expect_true(length(sel$selected_feats) > 0) # there ARE selections
- ord <- order(props, decreasing=TRUE)
- is_sel <- (seq_along(props) %in% as.integer(sel$selected_feats))[ord]
- testthat::expect_true(any(is_sel)) # NON-empty highlight
- testthat::expect_equal(sum(is_sel), length(sel$selected_feats))
- # The highlighted bars are exactly the selected features, by ORIGINAL index.
- testthat::expect_setequal(ord[is_sel], as.integer(sel$selected_feats))
-
- # Contrast: a NAME-based highlight WOULD have failed here (names are NULL, so
- # names(props) %in% ... is logical(0) -> no bar highlighted).
- testthat::expect_false(any(names(props) %in%
- as.character(sel$selected_feats)))
-
- grDevices::dev.off()
-})
-
-testthat::test_that("plot.cssr forwards ... to barplot without a duplicate-arg crash (B1)", {
- # The method builds a SINGLE merged barplot arg list, so graphical params on
- # ... cannot collide with col/ylim/height (which previously crashed with
- # "formal argument 'col' matched by multiple actual arguments").
- set.seed(26717)
- x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
- colnames(x) <- paste0("V", seq_len(ncol(x)))
- 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)
-
- grDevices::pdf(NULL)
- testthat::expect_no_error(plot(css_res, col="red"))
- testthat::expect_no_error(plot(css_res, ylim=c(0, 0.5)))
- testthat::expect_no_error(plot(css_res, main="x"))
- testthat::expect_no_error(plot(css_res, type="features", col="red",
- main="feats"))
- grDevices::dev.off()
-})
-
-testthat::test_that("plot.cssr handles an empty selection and a single cluster", {
- # (e) Empty selection: min_num_clusts = 0 with a cutoff strictly above every
- # cluster proportion selects nothing (min_num_clusts = 1 is never empty). All
- # bars get unsel_col, there is no highlight, and there is no crash.
- 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)
- max_prop <- max(colMeans(css_res$clus_sel_mat))
- testthat::expect_true(max_prop < 1)
- cut <- (max_prop + 1) / 2 # strictly between max_prop and 1 (and <= 1)
- sel <- getCssSelections(css_res, cutoff=cut, min_num_clusts=0)
- testthat::expect_length(sel$selected_clusts, 0) # genuinely empty
-
- grDevices::pdf(NULL)
- # A bare call that errored would fail the test -> this asserts "no crash".
- ret <- plot(css_res, min_num_clusts=0, cutoff=cut)
- testthat::expect_equal(ret,
- sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE))
- grDevices::dev.off()
-
- # (f) Single-cluster css: clus_sel_mat has exactly one column -> a length-1
- # barplot, no error.
- set.seed(1)
- x1 <- matrix(stats::rnorm(10*4), nrow=10, ncol=4)
- y1 <- stats::rnorm(10)
- css_1 <- css(X=x1, y=y1, lambda=0.01, clusters=list(all=1:4), B=10)
- testthat::expect_equal(ncol(css_1$clus_sel_mat), 1)
-
- grDevices::pdf(NULL)
- ret1 <- plot(css_1)
- testthat::expect_length(ret1, 1)
- grDevices::dev.off()
-})
-
-testthat::test_that("plot.cssr surfaces the tie-breach warning (#159c)", {
- # plot.cssr no longer wraps getCssSelections in suppressWarnings, so a
- # max_num_clusts breach reaches the user. Two clusters tied at proportion 1.0
- # with max_num_clusts = 1 cannot be reduced below 2 without emptying the
- # selection, so checkSelectedClusters warns. Pre-#159c the blanket
- # suppressWarnings swallowed it, so this test FAILS on the old code.
- B <- 10
- clusters <- list(c1 = 1L, c2 = 2L)
- clus_sel_mat <- cbind(c1 = rep(1L, B), c2 = rep(1L, B))
- feat_sel_mat <- cbind(f1 = rep(1L, B), f2 = rep(1L, B))
- obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat,
- clusters = clusters), class = "cssr")
-
- grDevices::pdf(NULL) # draw to a null device (no file, no window)
- on.exit(grDevices::dev.off(), add = TRUE)
- testthat::expect_warning(plot(obj, max_num_clusts = 1),
- "Returning more than max_num_clusts", fixed = TRUE)
-})
+testthat::test_that("plot.cssr draws cluster proportions and returns them sorted", {
+ # Named X so the feature matrix (tested below) carries feature names.
+ set.seed(26717)
+ x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
+ colnames(x) <- paste0("V", seq_len(ncol(x)))
+ 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)
+
+ grDevices::pdf(NULL) # draw to a null device (no file, no window)
+
+ # (a) Clusters (default): runs without error and invisibly returns the sorted
+ # named cluster selection proportions (a deterministic proof of the return).
+ testthat::expect_invisible(plot(css_res))
+ ret <- plot(css_res)
+ testthat::expect_equal(ret,
+ sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE))
+ testthat::expect_false(is.null(names(ret))) # cluster names guaranteed
+
+ # (b) Features, NAMED X: returns the sorted NAMED feature selection
+ # proportions, and the (index-based) highlight matches getCssSelections().
+ ret_f <- plot(css_res, type="features")
+ props_f <- colMeans(css_res$feat_sel_mat)
+ testthat::expect_equal(ret_f, sort(props_f, decreasing=TRUE))
+ testthat::expect_identical(names(ret_f),
+ paste0("V", order(props_f, decreasing=TRUE))) # named + correctly ordered
+ sel_f <- getCssSelections(css_res, weighting="sparse")
+ ord <- order(props_f, decreasing=TRUE)
+ is_sel <- (seq_along(props_f) %in% as.integer(sel_f$selected_feats))[ord]
+ testthat::expect_equal(sum(is_sel), length(sel_f$selected_feats))
+ testthat::expect_setequal(ord[is_sel], as.integer(sel_f$selected_feats))
+
+ grDevices::dev.off()
+})
+
+testthat::test_that("plot.cssr feature highlight is index-based for unnamed X (B2)", {
+ # genClusteredData returns X with NULL colnames -> feat_sel_mat is UNNAMED.
+ # A name-based feature highlight would silently be all-FALSE; the method uses
+ # an INDEX-based highlight, which must still be non-empty. This is the B2
+ # regression proof.
+ set.seed(721)
+ dat <- genClusteredData(n=60, p=11, k_unclustered=2, cluster_size=4,
+ n_clusters=1, snr=3)
+ clusters <- list(cluster1=1:4)
+ css_res <- suppressWarnings(css(X=dat$X, y=dat$y, lambda=0.01,
+ clusters=clusters, B=10))
+
+ # Precondition for the B2 guard: the feature matrix really is unnamed.
+ testthat::expect_null(colnames(css_res$feat_sel_mat))
+
+ grDevices::pdf(NULL)
+
+ props <- colMeans(css_res$feat_sel_mat)
+ ret <- plot(css_res, type="features", cutoff=0.3)
+ # Returns the plain (unnamed) sorted colMeans regardless of the cutoff.
+ testthat::expect_equal(ret, sort(props, decreasing=TRUE))
+ testthat::expect_null(names(ret))
+
+ # Re-derive the highlight exactly as plot.cssr does: INDEX-based.
+ sel <- getCssSelections(css_res, weighting="sparse", cutoff=0.3)
+ testthat::expect_true(length(sel$selected_feats) > 0) # there ARE selections
+ ord <- order(props, decreasing=TRUE)
+ is_sel <- (seq_along(props) %in% as.integer(sel$selected_feats))[ord]
+ testthat::expect_true(any(is_sel)) # NON-empty highlight
+ testthat::expect_equal(sum(is_sel), length(sel$selected_feats))
+ # The highlighted bars are exactly the selected features, by ORIGINAL index.
+ testthat::expect_setequal(ord[is_sel], as.integer(sel$selected_feats))
+
+ # Contrast: a NAME-based highlight WOULD have failed here (names are NULL, so
+ # names(props) %in% ... is logical(0) -> no bar highlighted).
+ testthat::expect_false(any(names(props) %in%
+ as.character(sel$selected_feats)))
+
+ grDevices::dev.off()
+})
+
+testthat::test_that("plot.cssr forwards ... to barplot without a duplicate-arg crash (B1)", {
+ # The method builds a SINGLE merged barplot arg list, so graphical params on
+ # ... cannot collide with col/ylim/height (which previously crashed with
+ # "formal argument 'col' matched by multiple actual arguments").
+ set.seed(26717)
+ x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
+ colnames(x) <- paste0("V", seq_len(ncol(x)))
+ 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)
+
+ grDevices::pdf(NULL)
+ testthat::expect_no_error(plot(css_res, col="red"))
+ testthat::expect_no_error(plot(css_res, ylim=c(0, 0.5)))
+ testthat::expect_no_error(plot(css_res, main="x"))
+ testthat::expect_no_error(plot(css_res, type="features", col="red",
+ main="feats"))
+ grDevices::dev.off()
+})
+
+testthat::test_that("plot.cssr handles an empty selection and a single cluster", {
+ # (e) Empty selection: min_num_clusts = 0 with a cutoff strictly above every
+ # cluster proportion selects nothing (min_num_clusts = 1 is never empty). All
+ # bars get unsel_col, there is no highlight, and there is no crash.
+ 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)
+ max_prop <- max(colMeans(css_res$clus_sel_mat))
+ testthat::expect_true(max_prop < 1)
+ cut <- (max_prop + 1) / 2 # strictly between max_prop and 1 (and <= 1)
+ sel <- getCssSelections(css_res, cutoff=cut, min_num_clusts=0)
+ testthat::expect_length(sel$selected_clusts, 0) # genuinely empty
+
+ grDevices::pdf(NULL)
+ # A bare call that errored would fail the test -> this asserts "no crash".
+ ret <- plot(css_res, min_num_clusts=0, cutoff=cut)
+ testthat::expect_equal(ret,
+ sort(colMeans(css_res$clus_sel_mat), decreasing=TRUE))
+ grDevices::dev.off()
+
+ # (f) Single-cluster css: clus_sel_mat has exactly one column -> a length-1
+ # barplot, no error.
+ set.seed(1)
+ x1 <- matrix(stats::rnorm(10*4), nrow=10, ncol=4)
+ y1 <- stats::rnorm(10)
+ css_1 <- css(X=x1, y=y1, lambda=0.01, clusters=list(all=1:4), B=10)
+ testthat::expect_equal(ncol(css_1$clus_sel_mat), 1)
+
+ grDevices::pdf(NULL)
+ ret1 <- plot(css_1)
+ testthat::expect_length(ret1, 1)
+ grDevices::dev.off()
+})
+
+testthat::test_that("plot.cssr surfaces the tie-breach warning (#159c)", {
+ # plot.cssr no longer wraps getCssSelections in suppressWarnings, so a
+ # max_num_clusts breach reaches the user. Two clusters tied at proportion 1.0
+ # with max_num_clusts = 1 cannot be reduced below 2 without emptying the
+ # selection, so checkSelectedClusters warns. Pre-#159c the blanket
+ # suppressWarnings swallowed it, so this test FAILS on the old code.
+ B <- 10
+ clusters <- list(c1 = 1L, c2 = 2L)
+ clus_sel_mat <- cbind(c1 = rep(1L, B), c2 = rep(1L, B))
+ feat_sel_mat <- cbind(f1 = rep(1L, B), f2 = rep(1L, B))
+ obj <- structure(list(feat_sel_mat = feat_sel_mat, clus_sel_mat = clus_sel_mat,
+ clusters = clusters), class = "cssr")
+
+ grDevices::pdf(NULL) # draw to a null device (no file, no window)
+ on.exit(grDevices::dev.off(), add = TRUE)
+ testthat::expect_warning(plot(obj, max_num_clusts = 1),
+ "Returning more than max_num_clusts", fixed = TRUE)
+})
## Test passed with 7 successes.
## Test passed with 8 successes.
## Test passed with 4 successes.
@@ -2913,160 +2913,160 @@
no col, the method’s own highlight colors still apply. The second checks that
the dashed cutoff line is drawn only for type = "clusters" (whose axis
matches the highlight) and never for type = "features".
-testthat::test_that("plot.cssr honors a user col in ... and otherwise applies the highlight (#160a)", {
- set.seed(26717)
- x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
- colnames(x) <- paste0("V", seq_len(ncol(x)))
- 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)
-
- # barplot is mocked (nothing is drawn) and cutoff = 0 (no abline), so no real
- # graphics call is made; the device is opened only defensively.
- grDevices::pdf(NULL)
- on.exit(grDevices::dev.off(), add=TRUE)
-
- # (a1) A user col in ... must reach barplot() verbatim. Before #160a the method
- # overwrote it with the highlight colors (this asserted "red" but got
- # steelblue/grey70).
- captured <- NULL
- testthat::with_mocked_bindings(
- barplot = function(...) captured <<- list(...),
- plot(css_res, col="red"),
- .package = "graphics"
- )
- testthat::expect_identical(captured$col, "red")
-
- # (a2) With no col the method's own highlight must STILL apply -- guards against
- # over-fixing (a1) by dropping the default. max_num_clusts=2 forces a genuine
- # mix (>=1 selected, >=1 unselected) so both ifelse branches are exercised.
- captured2 <- NULL
- testthat::with_mocked_bindings(
- barplot = function(...) captured2 <<- list(...),
- plot(css_res, max_num_clusts=2),
- .package = "graphics"
- )
- props <- colMeans(css_res$clus_sel_mat)
- sel <- suppressWarnings(getCssSelections(css_res, weighting="sparse",
- cutoff=0, min_num_clusts=1, max_num_clusts=2))
- is_sel <- (names(props) %in% names(sel$selected_clusts))[order(props,
- decreasing=TRUE)]
- testthat::expect_identical(captured2$col, ifelse(is_sel, "steelblue", "grey70"))
- testthat::expect_true("steelblue" %in% captured2$col) # a genuine mix, so both
- testthat::expect_true("grey70" %in% captured2$col) # branches are covered
-})
-
-testthat::test_that("plot.cssr draws the cutoff line only for type='clusters' (#160b)", {
- set.seed(26717)
- x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
- colnames(x) <- paste0("V", seq_len(ncol(x)))
- 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)
-
- # Real barplot draws to a null device; only abline is mocked (a flag/capture).
- grDevices::pdf(NULL)
- on.exit(grDevices::dev.off(), add=TRUE)
-
- # (b1) type="features": the line would sit on the feature-proportion axis while
- # highlighting follows cluster selection, so no reference line is drawn (#160b).
- called <- FALSE
- testthat::with_mocked_bindings(
- abline = function(...) called <<- TRUE,
- plot(css_res, type="features", cutoff=0.6),
- .package = "graphics"
- )
- testthat::expect_false(called)
-
- # (b2) type="clusters": the line's axis matches the highlight, so it IS drawn at
- # h = cutoff.
- called <- FALSE
- ab_args <- NULL
- testthat::with_mocked_bindings(
- abline = function(...) { called <<- TRUE; ab_args <<- list(...) },
- plot(css_res, type="clusters", cutoff=0.6),
- .package = "graphics"
- )
- testthat::expect_true(called)
- testthat::expect_equal(ab_args$h, 0.6)
-
- # (b3) cutoff=0: no line in either mode (unchanged behavior).
- called <- FALSE
- testthat::with_mocked_bindings(
- abline = function(...) called <<- TRUE,
- plot(css_res, type="clusters", cutoff=0),
- .package = "graphics"
- )
- testthat::expect_false(called)
-})
+testthat::test_that("plot.cssr honors a user col in ... and otherwise applies the highlight (#160a)", {
+ set.seed(26717)
+ x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
+ colnames(x) <- paste0("V", seq_len(ncol(x)))
+ 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)
+
+ # barplot is mocked (nothing is drawn) and cutoff = 0 (no abline), so no real
+ # graphics call is made; the device is opened only defensively.
+ grDevices::pdf(NULL)
+ on.exit(grDevices::dev.off(), add=TRUE)
+
+ # (a1) A user col in ... must reach barplot() verbatim. Before #160a the method
+ # overwrote it with the highlight colors (this asserted "red" but got
+ # steelblue/grey70).
+ captured <- NULL
+ testthat::with_mocked_bindings(
+ barplot = function(...) captured <<- list(...),
+ plot(css_res, col="red"),
+ .package = "graphics"
+ )
+ testthat::expect_identical(captured$col, "red")
+
+ # (a2) With no col the method's own highlight must STILL apply -- guards against
+ # over-fixing (a1) by dropping the default. max_num_clusts=2 forces a genuine
+ # mix (>=1 selected, >=1 unselected) so both ifelse branches are exercised.
+ captured2 <- NULL
+ testthat::with_mocked_bindings(
+ barplot = function(...) captured2 <<- list(...),
+ plot(css_res, max_num_clusts=2),
+ .package = "graphics"
+ )
+ props <- colMeans(css_res$clus_sel_mat)
+ sel <- suppressWarnings(getCssSelections(css_res, weighting="sparse",
+ cutoff=0, min_num_clusts=1, max_num_clusts=2))
+ is_sel <- (names(props) %in% names(sel$selected_clusts))[order(props,
+ decreasing=TRUE)]
+ testthat::expect_identical(captured2$col, ifelse(is_sel, "steelblue", "grey70"))
+ testthat::expect_true("steelblue" %in% captured2$col) # a genuine mix, so both
+ testthat::expect_true("grey70" %in% captured2$col) # branches are covered
+})
+
+testthat::test_that("plot.cssr draws the cutoff line only for type='clusters' (#160b)", {
+ set.seed(26717)
+ x <- matrix(stats::rnorm(10*7), nrow=10, ncol=7)
+ colnames(x) <- paste0("V", seq_len(ncol(x)))
+ 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)
+
+ # Real barplot draws to a null device; only abline is mocked (a flag/capture).
+ grDevices::pdf(NULL)
+ on.exit(grDevices::dev.off(), add=TRUE)
+
+ # (b1) type="features": the line would sit on the feature-proportion axis while
+ # highlighting follows cluster selection, so no reference line is drawn (#160b).
+ called <- FALSE
+ testthat::with_mocked_bindings(
+ abline = function(...) called <<- TRUE,
+ plot(css_res, type="features", cutoff=0.6),
+ .package = "graphics"
+ )
+ testthat::expect_false(called)
+
+ # (b2) type="clusters": the line's axis matches the highlight, so it IS drawn at
+ # h = cutoff.
+ called <- FALSE
+ ab_args <- NULL
+ testthat::with_mocked_bindings(
+ abline = function(...) { called <<- TRUE; ab_args <<- list(...) },
+ plot(css_res, type="clusters", cutoff=0.6),
+ .package = "graphics"
+ )
+ testthat::expect_true(called)
+ testthat::expect_equal(ab_args$h, 0.6)
+
+ # (b3) cutoff=0: no line in either mode (unchanged behavior).
+ called <- FALSE
+ testthat::with_mocked_bindings(
+ abline = function(...) called <<- TRUE,
+ plot(css_res, type="clusters", cutoff=0),
+ .package = "graphics"
+ )
+ testthat::expect_false(called)
+})
## Test passed with 4 successes.
## Test passed with 4 successes.
Byte-identity tests for the issue #129 performance micro-optimizations. Each asserts that the de-duplicated / hoisted path returns a value identical to the recomputed path it replaced. Per issue #129 these compare RETURN VALUES (wrapped in suppressWarnings), never warning counts: Opts 2 and 3 intentionally collapse repeated getSelectedClusters() calls, which only de-duplicates a warning side-channel and leaves the returned objects unchanged.
-testthat::test_that("Opt 2 (#129): formCssDesign weights= equals internal recompute; getCssPreds finite", {
- set.seed(721)
- dat <- genClusteredData(n = 60, p = 11, k_unclustered = 2, cluster_size = 4,
- n_clusters = 1, snr = 3)
- clusters <- list(cluster1 = 1:4)
- res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
- clusters = clusters, B = 15))
-
- # The hoist: passing weights= (as getCssPreds now does) must build a design
- # matrix byte-identical to letting formCssDesign() recompute the weights via
- # getSelectedClusters(), across every weighting rule.
- for(w in c("sparse", "weighted_avg", "simple_avg")){
- wts <- getSelectedClusters(res, w, 0, 1, NA)$weights
- d_recompute <- suppressWarnings(formCssDesign(res, weighting = w,
- newx = dat$X))
- d_passed <- suppressWarnings(formCssDesign(res, weighting = w,
- newx = dat$X, weights = wts))
- testthat::expect_identical(d_passed, d_recompute)
- }
-
- # End-to-end getCssPreds still returns finite predictions of the right length
- # for both the provided-trainX path and the train_inds path, across weightings.
- res_ti <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
- clusters = clusters, B = 15, train_inds = 41:60))
- for(w in c("sparse", "weighted_avg", "simple_avg")){
- p_prov <- suppressWarnings(getCssPreds(res, testX = dat$X[1:10, ],
- trainX = dat$X[11:40, ], trainY = dat$y[11:40], weighting = w))
- testthat::expect_length(p_prov, 10)
- testthat::expect_true(all(is.finite(p_prov)))
- p_ti <- suppressWarnings(getCssPreds(res_ti, testX = dat$X[1:10, ],
- weighting = w))
- testthat::expect_length(p_ti, 10)
- testthat::expect_true(all(is.finite(p_ti)))
- }
-})
-
-testthat::test_that("Opt 3 (#129): buildCssDf equals printCssDf; summary$table reuses it", {
- set.seed(824)
- dat <- genClusteredData(n = 55, p = 11, k_unclustered = 2, cluster_size = 4,
- n_clusters = 1, snr = 3)
- clusters <- list(cluster1 = 1:4)
- res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
- clusters = clusters, B = 12))
-
- # buildCssDf(obj, getCssSelections(obj, ...)$selected_clusts) reproduces
- # printCssDf(obj, ...) exactly, across cutoffs (including the empty selection
- # at cutoff = 1 with min_num_clusts = 0).
- for(cut in c(0, 0.2, 0.5, 1)){
- sc <- suppressWarnings(getCssSelections(res, cutoff = cut,
- min_num_clusts = 0))$selected_clusts
- testthat::expect_identical(
- suppressWarnings(buildCssDf(res, sc)),
- suppressWarnings(printCssDf(res, cutoff = cut, min_num_clusts = 0)))
- }
-
- # summary.cssr()$table (now built via buildCssDf() on summary's own
- # sel$selected_clusts) equals printCssDf() on the same object across
- # weightings -- cluster selection is weighting-invariant, so reusing summary's
- # sel$selected_clusts is byte-identical to printCssDf's internal recompute.
- ref <- suppressWarnings(printCssDf(res))
- for(w in c("sparse", "weighted_avg", "simple_avg")){
- s <- suppressWarnings(summary(res, weighting = w))
- testthat::expect_identical(s$table, ref)
- }
-})
+testthat::test_that("Opt 2 (#129): formCssDesign weights= equals internal recompute; getCssPreds finite", {
+ set.seed(721)
+ dat <- genClusteredData(n = 60, p = 11, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 1, snr = 3)
+ clusters <- list(cluster1 = 1:4)
+ res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
+ clusters = clusters, B = 15))
+
+ # The hoist: passing weights= (as getCssPreds now does) must build a design
+ # matrix byte-identical to letting formCssDesign() recompute the weights via
+ # getSelectedClusters(), across every weighting rule.
+ for(w in c("sparse", "weighted_avg", "simple_avg")){
+ wts <- getSelectedClusters(res, w, 0, 1, NA)$weights
+ d_recompute <- suppressWarnings(formCssDesign(res, weighting = w,
+ newx = dat$X))
+ d_passed <- suppressWarnings(formCssDesign(res, weighting = w,
+ newx = dat$X, weights = wts))
+ testthat::expect_identical(d_passed, d_recompute)
+ }
+
+ # End-to-end getCssPreds still returns finite predictions of the right length
+ # for both the provided-trainX path and the train_inds path, across weightings.
+ res_ti <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
+ clusters = clusters, B = 15, train_inds = 41:60))
+ for(w in c("sparse", "weighted_avg", "simple_avg")){
+ p_prov <- suppressWarnings(getCssPreds(res, testX = dat$X[1:10, ],
+ trainX = dat$X[11:40, ], trainY = dat$y[11:40], weighting = w))
+ testthat::expect_length(p_prov, 10)
+ testthat::expect_true(all(is.finite(p_prov)))
+ p_ti <- suppressWarnings(getCssPreds(res_ti, testX = dat$X[1:10, ],
+ weighting = w))
+ testthat::expect_length(p_ti, 10)
+ testthat::expect_true(all(is.finite(p_ti)))
+ }
+})
+
+testthat::test_that("Opt 3 (#129): buildCssDf equals printCssDf; summary$table reuses it", {
+ set.seed(824)
+ dat <- genClusteredData(n = 55, p = 11, k_unclustered = 2, cluster_size = 4,
+ n_clusters = 1, snr = 3)
+ clusters <- list(cluster1 = 1:4)
+ res <- suppressWarnings(css(X = dat$X, y = dat$y, lambda = 0.01,
+ clusters = clusters, B = 12))
+
+ # buildCssDf(obj, getCssSelections(obj, ...)$selected_clusts) reproduces
+ # printCssDf(obj, ...) exactly, across cutoffs (including the empty selection
+ # at cutoff = 1 with min_num_clusts = 0).
+ for(cut in c(0, 0.2, 0.5, 1)){
+ sc <- suppressWarnings(getCssSelections(res, cutoff = cut,
+ min_num_clusts = 0))$selected_clusts
+ testthat::expect_identical(
+ suppressWarnings(buildCssDf(res, sc)),
+ suppressWarnings(printCssDf(res, cutoff = cut, min_num_clusts = 0)))
+ }
+
+ # summary.cssr()$table (now built via buildCssDf() on summary's own
+ # sel$selected_clusts) equals printCssDf() on the same object across
+ # weightings -- cluster selection is weighting-invariant, so reusing summary's
+ # sel$selected_clusts is byte-identical to printCssDf's internal recompute.
+ ref <- suppressWarnings(printCssDf(res))
+ for(w in c("sparse", "weighted_avg", "simple_avg")){
+ s <- suppressWarnings(summary(res, weighting = w))
+ testthat::expect_identical(s$table, ref)
+ }
+})
## Test passed with 15 successes.
## Test passed with 7 successes.
## Test passed with 60 successes.## Test passed with 2 successes.## Test passed with 6 successes.## Test passed with 4 successes.## Test passed with 3 successes.## Test passed with 5 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)
-})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)
-})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)
+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)
@@ -1119,170 +1124,108 @@
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
- res <- checkNewXProvided(x_new, css_res)
+ res <- checkXInputResults(x_new, css_res$X)
testthat::expect_true(is.list(res))
- testthat::expect_identical(names(res), c("newX", "newXProvided", "feat_names"))
+ testthat::expect_identical(names(res), c("feat_names", "newx"))
- 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.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))
- 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
+ # 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)
- 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)
+ # 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]
- # Things should still work if new x is not provided
+ res_named <- checkXInputResults(x_new, css_res_named$X)
- 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)
+ 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)
- # 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)
+ 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))
- # 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)
+ # 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)
- 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])
+ 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)"]
- # Try data.frame input to css and checkNewXProvided
+ testthat::expect_identical(res_df$feat_names, colnames(mat))
- 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)
+ 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*6), nrow=10, ncol=6)
- x_new <- matrix(stats::rnorm(8*6), nrow=8, ncol=6)
+ 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)
@@ -1291,287 +1234,167 @@
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 <- 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)
- 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)
+ # 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)
- # 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]
+ 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])
- 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)
+ # 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)
@@ -1583,240 +1406,287 @@
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
+ 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_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 <- 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
- colnames(x_new) <- LETTERS[1:6]
+ X_df <- datasets::mtcars
- 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)
+ 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))
- 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
+ # 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(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)
+ 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)
@@ -1827,8 +1697,8 @@
css_res <- css(X=x_select, y=y_select, lambda=0.01, clusters=good_clusters,
B = 10)
-
- res <- getCssDesign(css_res, newX=x_new)
+
+ res <- formCssDesign(css_res, newx=x_new)
testthat::expect_true(is.matrix(res))
testthat::expect_true(is.numeric(res))
@@ -1837,669 +1707,510 @@
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)
+ # 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)
+ }
+ }
+ }
+ }
- # 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)
+ # 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
- # 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)
+ 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)
- 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)
+ 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)
- 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)))
+ # 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)
- 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)
+ 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
- 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, ])
+ X_df <- datasets::mtcars
+
+ n <- nrow(X_df)
+ y <- stats::rnorm(n)
- 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
+ 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, ])
- 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_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)))
- 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)
+ # 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)
- testthat::expect_error(getCssDesign(css_results=css_res,
- weighting=c("sparse", "simple_avg"),
- newX=x_new),
- "length(weighting) == 1 is not TRUE", fixed=TRUE)
+ 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_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_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(getCssDesign(css_results=css_res, max_num_clusts=3.5,
- newX=x_new),
- "max_num_clusts == round(max_num_clusts) is not 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(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)
+ 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)
-})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)
+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)
- 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
- # checkGetCssPredsInputs() validates testX and trainX separately, and both
- # are unnamed here while the css X was named, so the warning fires once per
- # matrix. Collect rather than nesting two expect_warning() calls: the woven
- # chunks run at testthat edition 2 (no DESCRIPTION at the repo root), where
- # expect_warning() consumes every warning and a nested pair fails. Asserting
- # the length also turns an unexpected third warning into a failure (#186).
- # Keep both assertions: all(grepl(...)) is vacuously TRUE on an empty
- # vector, so expect_length() is what makes the pair non-blind.
- name_warns <- testthat::capture_warnings(
- 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_length(name_warns, 2)
- testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.",
- name_warns, 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)))
-
-
-})
-## Test passed with 126 successes.
-Finally, tests for getCssPreds()
-testthat::test_that("getCssPreds works", {
- set.seed(70811)
+ 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)
@@ -2512,293 +2223,697 @@
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)
+ 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)
- ##### 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(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(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(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(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_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_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
+ 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)))
- 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
- # As at the checkGetCssPredsInputs site: testX and trainX are both unnamed,
- # so the warning fires once per matrix. Collected rather than nested for the
- # same edition-2 reason, and both assertions kept for the same reason (#186).
- name_warns <- testthat::capture_warnings(
- getCssPreds(css_res_named, testX=x_pred, trainX=x_train,
- trainY=y_train))
- testthat::expect_length(name_warns, 2)
- testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.",
- name_warns, 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
+ 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)))
- n <- nrow(X_df)
- y <- stats::rnorm(n)
+ testthat::expect_true(is.character(res$feat_names))
+ testthat::expect_true(is.na(res$feat_names))
- 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)
-
-})
+ 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
+ # checkGetCssPredsInputs() validates testX and trainX separately, and both
+ # are unnamed here while the css X was named, so the warning fires once per
+ # matrix. Collect rather than nesting two expect_warning() calls: the woven
+ # chunks run at testthat edition 2 (no DESCRIPTION at the repo root), where
+ # expect_warning() consumes every warning and a nested pair fails. Asserting
+ # the length also turns an unexpected third warning into a failure (#186).
+ # Keep both assertions: all(grepl(...)) is vacuously TRUE on an empty
+ # vector, so expect_length() is what makes the pair non-blind.
+ name_warns <- testthat::capture_warnings(
+ 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_length(name_warns, 2)
+ testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.",
+ name_warns, 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)))
+
+
+})## Test passed with 126 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
+ # As at the checkGetCssPredsInputs site: testX and trainX are both unnamed,
+ # so the warning fires once per matrix. Collected rather than nested for the
+ # same edition-2 reason, and both assertions kept for the same reason (#186).
+ name_warns <- testthat::capture_warnings(
+ getCssPreds(css_res_named, testX=x_pred, trainX=x_train,
+ trainY=y_train))
+ testthat::expect_length(name_warns, 2)
+ testthat::expect_true(all(grepl("New X provided had no variable names (column names) even though the X provided to css did.",
+ name_warns, 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)
+
+})## Test passed with 68 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
@@ -2806,63 +2921,63 @@
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)
-})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
@@ -2872,143 +2987,107 @@
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)
-})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).
- # glmnet's own C++ convergence nag fires on this fixture. It is not
- # asserted, because that would pin a foreign optimizer's behavior, which can
- # differ across glmnet versions, platforms and BLAS. The predicate matches
- # glmnet's shared C++-error prefix, so it muffles that whole class -- a
- # tighter one would pin the very detail we are avoiding. Every non-glmnet
- # warning from this call still reaches the reporter (#186).
- css_no_train <- withCallingHandlers(
- css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10),
- warning = function(w) {
- if (grepl("from glmnet C++ code", conditionMessage(w), fixed = TRUE)) {
- invokeRestart("muffleWarning")
- }
- })
- # 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)
-})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).
+ # glmnet's own C++ convergence nag fires on this fixture. It is not
+ # asserted, because that would pin a foreign optimizer's behavior, which can
+ # differ across glmnet versions, platforms and BLAS. The predicate matches
+ # glmnet's shared C++-error prefix, so it muffles that whole class -- a
+ # tighter one would pin the very detail we are avoiding. Every non-glmnet
+ # warning from this call still reaches the reporter (#186).
+ css_no_train <- withCallingHandlers(
+ css(X = X, y = y, lambda = 0.01, clusters = clusters, B = 10),
+ warning = function(w) {
+ if (grepl("from glmnet C++ code", conditionMessage(w), fixed = TRUE)) {
+ invokeRestart("muffleWarning")
+ }
+ })
+ # 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)
+})## 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)", {
+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)
@@ -3018,39 +3097,33 @@
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]
+ trainX_named <- X[21:40, ]
+ 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,
+ preds <- withCallingHandlers(
+ getCssPreds(res_ti, testX = testX_unnamed, trainX = trainX_named,
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)
-})
+
+ # 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 + named testX fires the testX asymmetry warning (#153c)", {
+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)
@@ -3061,118 +3134,160 @@
B = 10, train_inds = 21:40)
trainX_unnamed <- X[21:40, ]; colnames(trainX_unnamed) <- NULL
- testX_named <- X[41:60, ]
+ testX_unnamed <- X[41:60, ]; colnames(testX_unnamed) <- NULL
trainY <- y[21:40]
ww <- character()
withCallingHandlers(
- getCssPreds(res_ti, testX = testX_named, trainX = trainX_unnamed,
+ getCssPreds(res_ti, testX = testX_unnamed, 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)", {
+ # 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)
- 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)
-})
+ 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))
-})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()
@@ -3180,107 +3295,107 @@
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)
-})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))
-})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))
+})## Test passed with 20 successes.Tests for cssSelect():
testthat::test_that("cssSelect works", {
- set.seed(73212)
-
- data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=1)
-
- x <- data$X
- y <- data$y
-
- # Intentionally don't provide clusters for all features, mix up formatting,
- # etc.
- good_clusters <- list(red_cluster=1L:3L, 4:6)
-
- res <- cssSelect(X=x, y=y, clusters=good_clusters)
-
- 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(!is.null(names(res$selected_clusts)))
- testthat::expect_true(is.character(names(res$selected_clusts)))
- testthat::expect_true(length(res$selected_clusts) <=
- length(res$selected_feats))
- # Total of 11 - 2*(3 - 1) = 7 clusters
- testthat::expect_true(length(res$selected_clusts) <= 7)
- testthat::expect_true(length(res$selected_clusts) >= 1)
-
- testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
- testthat::expect_equal(length(res$selected_feats),
- length(unique(res$selected_feats)))
-
- # No provided clusters
-
- res <- cssSelect(X=x, y=y)
-
- 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(!is.null(names(res$selected_clusts)))
- testthat::expect_true(is.character(names(res$selected_clusts)))
- testthat::expect_true(length(res$selected_clusts) <=
- length(res$selected_feats))
-
- testthat::expect_true(length(res$selected_clusts) <= 11)
- testthat::expect_true(length(res$selected_clusts) >= 1)
-
- testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
- testthat::expect_equal(length(res$selected_feats),
- length(unique(res$selected_feats)))
-
- ## Trying other inputs
-
- # X as a data.frame
- X_df <- datasets::mtcars
-
- # cssSelect() reports a max_num_clusts tie on this draw. It is not asserted,
- # because whether the tie occurs depends on the estimated model size and so
- # on glmnet's lasso path rather than on cssr; the warning has deterministic
- # coverage in "checkSelectedClusters works" and in the #159c plot.cssr test.
- # Muffling just that one message leaves every other warning visible (#186).
- res <- withCallingHandlers(
- cssSelect(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3),
- warning = function(w) {
- if (grepl("Returning more than max_num_clusts", conditionMessage(w),
- fixed = TRUE)) {
- invokeRestart("muffleWarning")
- }
- })
-
- 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(!is.null(names(res$selected_clusts)))
- testthat::expect_true(is.character(names(res$selected_clusts)))
- testthat::expect_true(length(res$selected_clusts) <=
- length(res$selected_feats))
- # Total of ncol(X_df) - (3 - 1) clusters
- testthat::expect_true(length(res$selected_clusts) <= ncol(X_df) - 2)
- testthat::expect_true(length(res$selected_clusts) >= 1)
-
- testthat::expect_true(is.list(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:ncol(X_df)))
- 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) <= ncol(X_df))
- testthat::expect_equal(length(already_used_feats),
- length(unique(already_used_feats)))
- testthat::expect_true(all(already_used_feats %in% 1:ncol(X_df)))
-
- testthat::expect_true(length(res$selected_feats) <= ncol(X_df))
- 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 <= ncol(X_df)))
- testthat::expect_equal(length(res$selected_feats),
- length(unique(res$selected_feats)))
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- # Should get error if I try to use data.frame with clusters, since data.frame
- # has factors with more than two levels
- testthat::expect_error(cssSelect(X=df2, y=stats::rnorm(nrow(X_df)),
- clusters=1:3),
- "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert the data.frame X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
-
- # Should be fine if I don't use clusters
- res <- cssSelect(X=df2, y=stats::rnorm(nrow(X_df)))
-
- X_df_mat <- stats::model.matrix(~ ., df2)
- X_df_mat <- X_df_mat[, colnames(X_df_mat) != "(Intercept)"]
- p <- ncol(X_df_mat)
-
- 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(!is.null(names(res$selected_clusts)))
- testthat::expect_true(is.character(names(res$selected_clusts)))
- testthat::expect_true(length(res$selected_clusts) <=
- length(res$selected_feats))
- # Total of p - (3 - 1) clusters
- testthat::expect_true(length(res$selected_clusts) <= p - 2)
- testthat::expect_true(length(res$selected_clusts) >= 1)
-
- testthat::expect_true(is.list(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:p))
- 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) <= p)
- testthat::expect_equal(length(already_used_feats),
- length(unique(already_used_feats)))
- testthat::expect_true(all(already_used_feats %in% 1:p))
-
- testthat::expect_true(length(res$selected_feats) <= p)
- 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 <= p))
- testthat::expect_equal(length(res$selected_feats),
- length(unique(res$selected_feats)))
-
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
-
- res <- cssSelect(X=x2, y=y, clusters=good_clusters)
-
- 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(!is.null(names(res$selected_clusts)))
- testthat::expect_true(is.character(names(res$selected_clusts)))
- testthat::expect_true(length(res$selected_clusts) <=
- length(res$selected_feats))
- # Total of 11 - 2*(3 - 1) = 7 clusters
- testthat::expect_true(length(res$selected_clusts) <= 7)
- testthat::expect_true(length(res$selected_clusts) >= 1)
-
- testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
- testthat::expect_equal(length(res$selected_feats),
- length(unique(res$selected_feats)))
-
- # Vary inputs
- res <- cssSelect(X=x, y=y, clusters=good_clusters, lambda=0.01)
-
- testthat::expect_true(is.list(res))
- testthat::expect_equal(length(res), 3)
- testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
- "weights"))
-
- res <- cssSelect(X=x, y=y, clusters=good_clusters, cutoff=0.6)
-
- testthat::expect_true(is.list(res))
- testthat::expect_equal(length(res), 3)
- testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
- "weights"))
-
- res <- cssSelect(X=x, y=y, clusters=good_clusters, max_num_clusts=6)
-
- 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) <= 6)
-
- res <- cssSelect(X=x, y=y, clusters=good_clusters, auto_select_size=FALSE)
-
- testthat::expect_true(is.list(res))
- testthat::expect_equal(length(res), 3)
- testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
- "weights"))
- # Total of 11 - 2*(3 - 1) = 7 clusters
- testthat::expect_equal(length(res$selected_clusts), 7)
-
- # Bad inputs
- testthat::expect_error(cssSelect(X=x[1:10, ], y=y),
- "n == length(y) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=character(5), y=y),
- "is.matrix(X) | is.data.frame(X) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=matrix(1:15, 5, 3)),
- "!is.matrix(y) is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=factor(rbinom(15, size=1, prob=.5))),
- "The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)",
- fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=y, clusters="clusters"),
- "is.numeric(clusters) | is.integer(clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=y, lambda=-.1),
- "For method cssLasso, lambda must be nonnegative.",
- fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=y, cutoff=1.1),
- "cutoff <= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=y, max_num_clusts=1000),
- "max_num_clusts <= p is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssSelect(X=x, y=y, auto_select_size=1),
- "is.logical(auto_select_size) is not TRUE", fixed=TRUE)
-
- # alpha = 0 (degenerate ridge) is rejected
- testthat::expect_error(cssSelect(X=x, y=y, alpha=0),
- "alpha > 0 is not TRUE", fixed=TRUE)
-
- # alpha > 1 is rejected
- testthat::expect_error(cssSelect(X=x, y=y, alpha=1.5),
- "alpha <= 1 is not TRUE", fixed=TRUE)
-
- # alpha = NA is rejected with a clear message (rather than a cryptic error
- # deep inside the bundling/subsampling logic). A bare (logical) NA trips the
- # type check first; a numeric NA reaches the dedicated !is.na guard.
- testthat::expect_error(cssSelect(X=x, y=y, alpha=NA),
- "is.numeric(alpha) | is.integer(alpha) is not TRUE",
- fixed=TRUE)
- testthat::expect_error(cssSelect(X=x, y=y, alpha=NA_real_),
- "!is.na(alpha) is not TRUE", fixed=TRUE)
-
- # An NA in the design matrix yields the shared friendly message (#56).
- x_na <- x; x_na[2, 1] <- NA
- testthat::expect_error(cssSelect(X=x_na, y=y),
- "must not contain missing", fixed=TRUE)
-
- # (#127) A single-column X reaches getLassoLambda as a matrix and now errors
- # with the clean "p >= 2 is not TRUE" message rather than a cryptic downstream
- # failure ("invalid 'times' argument").
- testthat::expect_error(
- cssSelect(matrix(stats::rnorm(40), nrow=40, ncol=1), stats::rnorm(40)),
- "p >= 2 is not TRUE", fixed=TRUE)
-})testthat::test_that("cssSelect works", {
+ set.seed(73212)
+
+ data <- genClusteredData(n=15, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=1)
+
+ x <- data$X
+ y <- data$y
+
+ # Intentionally don't provide clusters for all features, mix up formatting,
+ # etc.
+ good_clusters <- list(red_cluster=1L:3L, 4:6)
+
+ res <- cssSelect(X=x, y=y, clusters=good_clusters)
+
+ 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(!is.null(names(res$selected_clusts)))
+ testthat::expect_true(is.character(names(res$selected_clusts)))
+ testthat::expect_true(length(res$selected_clusts) <=
+ length(res$selected_feats))
+ # Total of 11 - 2*(3 - 1) = 7 clusters
+ testthat::expect_true(length(res$selected_clusts) <= 7)
+ testthat::expect_true(length(res$selected_clusts) >= 1)
+
+ testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
+ testthat::expect_equal(length(res$selected_feats),
+ length(unique(res$selected_feats)))
+
+ # No provided clusters
+
+ res <- cssSelect(X=x, y=y)
+
+ 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(!is.null(names(res$selected_clusts)))
+ testthat::expect_true(is.character(names(res$selected_clusts)))
+ testthat::expect_true(length(res$selected_clusts) <=
+ length(res$selected_feats))
+
+ testthat::expect_true(length(res$selected_clusts) <= 11)
+ testthat::expect_true(length(res$selected_clusts) >= 1)
+
+ testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
+ testthat::expect_equal(length(res$selected_feats),
+ length(unique(res$selected_feats)))
+
+ ## Trying other inputs
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+
+ # cssSelect() reports a max_num_clusts tie on this draw. It is not asserted,
+ # because whether the tie occurs depends on the estimated model size and so
+ # on glmnet's lasso path rather than on cssr; the warning has deterministic
+ # coverage in "checkSelectedClusters works" and in the #159c plot.cssr test.
+ # Muffling just that one message leaves every other warning visible (#186).
+ res <- withCallingHandlers(
+ cssSelect(X=X_df, y=stats::rnorm(nrow(X_df)), clusters=1:3),
+ warning = function(w) {
+ if (grepl("Returning more than max_num_clusts", conditionMessage(w),
+ fixed = TRUE)) {
+ invokeRestart("muffleWarning")
+ }
+ })
+
+ 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(!is.null(names(res$selected_clusts)))
+ testthat::expect_true(is.character(names(res$selected_clusts)))
+ testthat::expect_true(length(res$selected_clusts) <=
+ length(res$selected_feats))
+ # Total of ncol(X_df) - (3 - 1) clusters
+ testthat::expect_true(length(res$selected_clusts) <= ncol(X_df) - 2)
+ testthat::expect_true(length(res$selected_clusts) >= 1)
+
+ testthat::expect_true(is.list(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:ncol(X_df)))
+ 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) <= ncol(X_df))
+ testthat::expect_equal(length(already_used_feats),
+ length(unique(already_used_feats)))
+ testthat::expect_true(all(already_used_feats %in% 1:ncol(X_df)))
+
+ testthat::expect_true(length(res$selected_feats) <= ncol(X_df))
+ 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 <= ncol(X_df)))
+ testthat::expect_equal(length(res$selected_feats),
+ length(unique(res$selected_feats)))
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ # Should get error if I try to use data.frame with clusters, since data.frame
+ # has factors with more than two levels
+ testthat::expect_error(cssSelect(X=df2, y=stats::rnorm(nrow(X_df)),
+ clusters=1:3),
+ "When stats::model.matrix converted the provided data.frame X to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert the data.frame X to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.", fixed=TRUE)
+
+ # Should be fine if I don't use clusters
+ res <- cssSelect(X=df2, y=stats::rnorm(nrow(X_df)))
+
+ X_df_mat <- stats::model.matrix(~ ., df2)
+ X_df_mat <- X_df_mat[, colnames(X_df_mat) != "(Intercept)"]
+ p <- ncol(X_df_mat)
+
+ 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(!is.null(names(res$selected_clusts)))
+ testthat::expect_true(is.character(names(res$selected_clusts)))
+ testthat::expect_true(length(res$selected_clusts) <=
+ length(res$selected_feats))
+ # Total of p - (3 - 1) clusters
+ testthat::expect_true(length(res$selected_clusts) <= p - 2)
+ testthat::expect_true(length(res$selected_clusts) >= 1)
+
+ testthat::expect_true(is.list(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:p))
+ 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) <= p)
+ testthat::expect_equal(length(already_used_feats),
+ length(unique(already_used_feats)))
+ testthat::expect_true(all(already_used_feats %in% 1:p))
+
+ testthat::expect_true(length(res$selected_feats) <= p)
+ 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 <= p))
+ testthat::expect_equal(length(res$selected_feats),
+ length(unique(res$selected_feats)))
+
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+
+ res <- cssSelect(X=x2, y=y, clusters=good_clusters)
+
+ 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(!is.null(names(res$selected_clusts)))
+ testthat::expect_true(is.character(names(res$selected_clusts)))
+ testthat::expect_true(length(res$selected_clusts) <=
+ length(res$selected_feats))
+ # Total of 11 - 2*(3 - 1) = 7 clusters
+ testthat::expect_true(length(res$selected_clusts) <= 7)
+ testthat::expect_true(length(res$selected_clusts) >= 1)
+
+ testthat::expect_true(is.list(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(length(res$selected_feats) <= 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 <= 11))
+ testthat::expect_equal(length(res$selected_feats),
+ length(unique(res$selected_feats)))
+
+ # Vary inputs
+ res <- cssSelect(X=x, y=y, clusters=good_clusters, lambda=0.01)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_equal(length(res), 3)
+ testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
+ "weights"))
+
+ res <- cssSelect(X=x, y=y, clusters=good_clusters, cutoff=0.6)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_equal(length(res), 3)
+ testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
+ "weights"))
+
+ res <- cssSelect(X=x, y=y, clusters=good_clusters, max_num_clusts=6)
+
+ 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) <= 6)
+
+ res <- cssSelect(X=x, y=y, clusters=good_clusters, auto_select_size=FALSE)
+
+ testthat::expect_true(is.list(res))
+ testthat::expect_equal(length(res), 3)
+ testthat::expect_identical(names(res), c("selected_clusts", "selected_feats",
+ "weights"))
+ # Total of 11 - 2*(3 - 1) = 7 clusters
+ testthat::expect_equal(length(res$selected_clusts), 7)
+
+ # Bad inputs
+ testthat::expect_error(cssSelect(X=x[1:10, ], y=y),
+ "n == length(y) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=character(5), y=y),
+ "is.matrix(X) | is.data.frame(X) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=matrix(1:15, 5, 3)),
+ "!is.matrix(y) is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=factor(rbinom(15, size=1, prob=.5))),
+ "The provided y must be real-valued, because cssSelect uses the lasso for feature selection. (In order to use a different form of response, use the css function and provide your own selection function accommodating your choice of y.)",
+ fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=y, clusters="clusters"),
+ "is.numeric(clusters) | is.integer(clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=y, lambda=-.1),
+ "For method cssLasso, lambda must be nonnegative.",
+ fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=y, cutoff=1.1),
+ "cutoff <= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=y, max_num_clusts=1000),
+ "max_num_clusts <= p is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssSelect(X=x, y=y, auto_select_size=1),
+ "is.logical(auto_select_size) is not TRUE", fixed=TRUE)
+
+ # alpha = 0 (degenerate ridge) is rejected
+ testthat::expect_error(cssSelect(X=x, y=y, alpha=0),
+ "alpha > 0 is not TRUE", fixed=TRUE)
+
+ # alpha > 1 is rejected
+ testthat::expect_error(cssSelect(X=x, y=y, alpha=1.5),
+ "alpha <= 1 is not TRUE", fixed=TRUE)
+
+ # alpha = NA is rejected with a clear message (rather than a cryptic error
+ # deep inside the bundling/subsampling logic). A bare (logical) NA trips the
+ # type check first; a numeric NA reaches the dedicated !is.na guard.
+ testthat::expect_error(cssSelect(X=x, y=y, alpha=NA),
+ "is.numeric(alpha) | is.integer(alpha) is not TRUE",
+ fixed=TRUE)
+ testthat::expect_error(cssSelect(X=x, y=y, alpha=NA_real_),
+ "!is.na(alpha) is not TRUE", fixed=TRUE)
+
+ # An NA in the design matrix yields the shared friendly message (#56).
+ x_na <- x; x_na[2, 1] <- NA
+ testthat::expect_error(cssSelect(X=x_na, y=y),
+ "must not contain missing", fixed=TRUE)
+
+ # (#127) A single-column X reaches getLassoLambda as a matrix and now errors
+ # with the clean "p >= 2 is not TRUE" message rather than a cryptic downstream
+ # failure ("invalid 'times' argument").
+ testthat::expect_error(
+ cssSelect(matrix(stats::rnorm(40), nrow=40, ncol=1), stats::rnorm(40)),
+ "p >= 2 is not TRUE", fixed=TRUE)
+})## Test passed with 220 successes.Tests confirming that a non-default alpha is threaded through cssSelect()
end-to-end and changes the selected set on a correlated-block design (this is
the wrapper-level analogue of the cssLasso headline test; it is new behavior
absent on main, where alpha could not affect selection):
testthat::test_that("cssSelect threads alpha through to selection", {
- set.seed(1)
- n <- 100
- p <- 20
- rho <- 0.9
- block <- 4
- Z <- matrix(stats::rnorm(n*p), n, p)
- common <- stats::rnorm(n)
- for(j in 1:block){
- Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j]
- }
- y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n))
-
- # Treat the correlated block as one cluster; the remaining features are
- # singletons. Fix lambda and the model size so the only thing that varies
- # between the two calls is alpha.
- clusters <- list(block=1:block)
-
- res_lasso <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251,
- max_num_clusts=p - block + 1, alpha=1)
- res_enet <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251,
- max_num_clusts=p - block + 1, alpha=0.5)
-
- # Both return a well-formed selection
- for(res in list(res_lasso, res_enet)){
- testthat::expect_true(is.list(res))
- testthat::expect_true(all(c("selected_clusts", "selected_feats") %in%
- names(res)))
- testthat::expect_true(is.integer(res$selected_feats))
- testthat::expect_true(all(res$selected_feats %in% 1:p))
- }
-
- # The elastic net selects (weakly) more features than the pure lasso on this
- # correlated design, and the two selected sets differ.
- testthat::expect_true(length(res_enet$selected_feats) >=
- length(res_lasso$selected_feats))
- testthat::expect_false(setequal(res_enet$selected_feats,
- res_lasso$selected_feats))
-})testthat::test_that("cssSelect threads alpha through to selection", {
+ set.seed(1)
+ n <- 100
+ p <- 20
+ rho <- 0.9
+ block <- 4
+ Z <- matrix(stats::rnorm(n*p), n, p)
+ common <- stats::rnorm(n)
+ for(j in 1:block){
+ Z[, j] <- sqrt(rho)*common + sqrt(1 - rho)*Z[, j]
+ }
+ y <- as.numeric(Z %*% c(rep(1, block), rep(0, p - block)) + stats::rnorm(n))
+
+ # Treat the correlated block as one cluster; the remaining features are
+ # singletons. Fix lambda and the model size so the only thing that varies
+ # between the two calls is alpha.
+ clusters <- list(block=1:block)
+
+ res_lasso <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251,
+ max_num_clusts=p - block + 1, alpha=1)
+ res_enet <- cssSelect(X=Z, y=y, clusters=clusters, lambda=3.72251,
+ max_num_clusts=p - block + 1, alpha=0.5)
+
+ # Both return a well-formed selection
+ for(res in list(res_lasso, res_enet)){
+ testthat::expect_true(is.list(res))
+ testthat::expect_true(all(c("selected_clusts", "selected_feats") %in%
+ names(res)))
+ testthat::expect_true(is.integer(res$selected_feats))
+ testthat::expect_true(all(res$selected_feats %in% 1:p))
+ }
+
+ # The elastic net selects (weakly) more features than the pure lasso on this
+ # correlated design, and the two selected sets differ.
+ testthat::expect_true(length(res_enet$selected_feats) >=
+ length(res_lasso$selected_feats))
+ testthat::expect_false(setequal(res_enet$selected_feats,
+ res_lasso$selected_feats))
+})## Test passed with 10 successes.Tests for cssPredict():
testthat::test_that("cssPredict works", {
- set.seed(84231)
-
- train_data <- genClusteredData(n=30, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=1)
-
- x <- train_data$X
- y <- train_data$y
-
- test_x <- genClusteredData(n=5, p=11, k_unclustered=2, cluster_size=3,
- n_clusters=2, sig_clusters=1, sigma_eps_sq=1)$X
-
- # Intentionally don't provide clusters for all features, mix up formatting,
- # etc.
- good_clusters <- list(red_cluster=1L:3L, 4:6)
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- clusters=good_clusters)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- # No provided clusters
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- # Provide training indices
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- train_inds=13:28)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- ## Trying other inputs
-
- # X as a data.frame
- X_df <- datasets::mtcars
-
- n <- nrow(X_df)
- test_inds <- 1:round(n/3)
- n_test <- length(test_inds)
- selec_train_inds <- setdiff(1:n, test_inds)
- n_selec_train <- length(selec_train_inds)
-
- res <- cssPredict(X_train_selec=X_df[selec_train_inds, ],
- y_train_selec=stats::rnorm(n_selec_train),
- X_test=X_df[test_inds, ])
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), n_test)
-
- # 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 df2)
- # cyl, gear, and carb are factors with more than 2 levels
- df2 <- X_df
- df2$cyl <- as.factor(df2$cyl)
- df2$vs <- as.factor(df2$vs)
- df2$am <- as.factor(df2$am)
- df2$gear <- as.factor(df2$gear)
- df2$carb <- as.factor(df2$carb)
-
- # Should get error if clusters are provided because df2 contains factors with
- # more than two levels
- testthat::expect_error(cssPredict(X_train_selec=df2[selec_train_inds, ],
- y_train_selec=stats::rnorm(n_selec_train),
- X_test=df2[test_inds, ], clusters=1:3),
- "When stats::model.matrix converted the provided data.frame X_train_selec to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X_train_selec to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.",
- fixed=TRUE)
-
- # Should be fine if no clusters are provided
- res <- cssPredict(X_train_selec=df2[selec_train_inds, ],
- y_train_selec=stats::rnorm(n_selec_train),
- X_test=df2[test_inds, ])
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), n_test)
-
- # X as a matrix with column names
- x2 <- x
- colnames(x2) <- LETTERS[1:11]
- test_x2 <- test_x
- colnames(test_x2) <- LETTERS[1:11]
-
- res <- cssPredict(X_train_selec=x2, y_train_selec=y, X_test=test_x2,
- clusters=good_clusters)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- # Vary inputs
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- lambda=0.01)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=0.6)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- max_num_clusts=6)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- auto_select_size=FALSE)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- # Non-default alpha (elastic net) threaded through end-to-end; smoke test
- # confirming it returns a well-formed prediction vector of the right length.
- res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
- alpha=0.5)
-
- testthat::expect_true(all(!is.na(res)))
- testthat::expect_true(is.numeric(res))
- testthat::expect_equal(length(res), 5)
-
- # Bad inputs
- testthat::expect_error(cssPredict(X_train_selec=x[1:10, ], y_train_selec=y,
- X_test=test_x),
- "length(y) == n is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=character(30),
- y_train_selec=y, X_test=test_x),
- "is.matrix(X_train_selec) | is.data.frame(X_train_selec) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x,
- y_train_selec=matrix(1:30, 10, 3),
- X_test=test_x), "!is.matrix(y) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x,
- y_train_selec=factor(rbinom(30, size=1,
- prob=.5)),
- X_test=test_x),
- "The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.",
- fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, clusters="clusters"),
- "is.numeric(clusters) | is.integer(clusters) is not TRUE",
- fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, lambda="lambda"),
- "For method cssLasso, lambda must be a numeric.",
- fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, cutoff=-.1),
- "cutoff >= 0 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, max_num_clusts=0),
- "max_num_clusts >= 1 is not TRUE", fixed=TRUE)
-
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, auto_select_size=c(TRUE,
- FALSE)),
- "length(auto_select_size) == 1 is not TRUE",
- fixed=TRUE)
-
- # alpha = 0 (degenerate ridge) is rejected
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, alpha=0),
- "alpha > 0 is not TRUE", fixed=TRUE)
-
- # alpha > 1 is rejected
- testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
- X_test=test_x, alpha=1.5),
- "alpha <= 1 is not TRUE", fixed=TRUE)
-
- # (#127) A single-column training design now reaches getLassoLambda as a matrix
- # (drop = FALSE on the subsample) and errors with the clean "p >= 2 is not
- # TRUE" message rather than "is.matrix(X) is not TRUE".
- testthat::expect_error(
- cssPredict(X_train_selec=matrix(stats::rnorm(40), nrow=40, ncol=1),
- y_train_selec=stats::rnorm(40),
- X_test=matrix(stats::rnorm(10), nrow=10, ncol=1)),
- "p >= 2 is not TRUE", fixed=TRUE)
-})testthat::test_that("cssPredict works", {
+ set.seed(84231)
+
+ train_data <- genClusteredData(n=30, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=1)
+
+ x <- train_data$X
+ y <- train_data$y
+
+ test_x <- genClusteredData(n=5, p=11, k_unclustered=2, cluster_size=3,
+ n_clusters=2, sig_clusters=1, sigma_eps_sq=1)$X
+
+ # Intentionally don't provide clusters for all features, mix up formatting,
+ # etc.
+ good_clusters <- list(red_cluster=1L:3L, 4:6)
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ clusters=good_clusters)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ # No provided clusters
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ # Provide training indices
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ train_inds=13:28)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ ## Trying other inputs
+
+ # X as a data.frame
+ X_df <- datasets::mtcars
+
+ n <- nrow(X_df)
+ test_inds <- 1:round(n/3)
+ n_test <- length(test_inds)
+ selec_train_inds <- setdiff(1:n, test_inds)
+ n_selec_train <- length(selec_train_inds)
+
+ res <- cssPredict(X_train_selec=X_df[selec_train_inds, ],
+ y_train_selec=stats::rnorm(n_selec_train),
+ X_test=X_df[test_inds, ])
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), n_test)
+
+ # 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 df2)
+ # cyl, gear, and carb are factors with more than 2 levels
+ df2 <- X_df
+ df2$cyl <- as.factor(df2$cyl)
+ df2$vs <- as.factor(df2$vs)
+ df2$am <- as.factor(df2$am)
+ df2$gear <- as.factor(df2$gear)
+ df2$carb <- as.factor(df2$carb)
+
+ # Should get error if clusters are provided because df2 contains factors with
+ # more than two levels
+ testthat::expect_error(cssPredict(X_train_selec=df2[selec_train_inds, ],
+ y_train_selec=stats::rnorm(n_selec_train),
+ X_test=df2[test_inds, ], clusters=1:3),
+ "When stats::model.matrix converted the provided data.frame X_train_selec to a matrix, the number of columns changed (probably because the provided data.frame contained a factor variable with at least three levels). Please convert X_train_selec to a matrix yourself using model.matrix and provide cluster assignments according to the columns of the new matrix.",
+ fixed=TRUE)
+
+ # Should be fine if no clusters are provided
+ res <- cssPredict(X_train_selec=df2[selec_train_inds, ],
+ y_train_selec=stats::rnorm(n_selec_train),
+ X_test=df2[test_inds, ])
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), n_test)
+
+ # X as a matrix with column names
+ x2 <- x
+ colnames(x2) <- LETTERS[1:11]
+ test_x2 <- test_x
+ colnames(test_x2) <- LETTERS[1:11]
+
+ res <- cssPredict(X_train_selec=x2, y_train_selec=y, X_test=test_x2,
+ clusters=good_clusters)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ # Vary inputs
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ lambda=0.01)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x, cutoff=0.6)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ max_num_clusts=6)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ auto_select_size=FALSE)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ # Non-default alpha (elastic net) threaded through end-to-end; smoke test
+ # confirming it returns a well-formed prediction vector of the right length.
+ res <- cssPredict(X_train_selec=x, y_train_selec=y, X_test=test_x,
+ alpha=0.5)
+
+ testthat::expect_true(all(!is.na(res)))
+ testthat::expect_true(is.numeric(res))
+ testthat::expect_equal(length(res), 5)
+
+ # Bad inputs
+ testthat::expect_error(cssPredict(X_train_selec=x[1:10, ], y_train_selec=y,
+ X_test=test_x),
+ "length(y) == n is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=character(30),
+ y_train_selec=y, X_test=test_x),
+ "is.matrix(X_train_selec) | is.data.frame(X_train_selec) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x,
+ y_train_selec=matrix(1:30, 10, 3),
+ X_test=test_x), "!is.matrix(y) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x,
+ y_train_selec=factor(rbinom(30, size=1,
+ prob=.5)),
+ X_test=test_x),
+ "The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.",
+ fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, clusters="clusters"),
+ "is.numeric(clusters) | is.integer(clusters) is not TRUE",
+ fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, lambda="lambda"),
+ "For method cssLasso, lambda must be a numeric.",
+ fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, cutoff=-.1),
+ "cutoff >= 0 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, max_num_clusts=0),
+ "max_num_clusts >= 1 is not TRUE", fixed=TRUE)
+
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, auto_select_size=c(TRUE,
+ FALSE)),
+ "length(auto_select_size) == 1 is not TRUE",
+ fixed=TRUE)
+
+ # alpha = 0 (degenerate ridge) is rejected
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, alpha=0),
+ "alpha > 0 is not TRUE", fixed=TRUE)
+
+ # alpha > 1 is rejected
+ testthat::expect_error(cssPredict(X_train_selec=x, y_train_selec=y,
+ X_test=test_x, alpha=1.5),
+ "alpha <= 1 is not TRUE", fixed=TRUE)
+
+ # (#127) A single-column training design now reaches getLassoLambda as a matrix
+ # (drop = FALSE on the subsample) and errors with the clean "p >= 2 is not
+ # TRUE" message rather than "is.matrix(X) is not TRUE".
+ testthat::expect_error(
+ cssPredict(X_train_selec=matrix(stats::rnorm(40), nrow=40, ncol=1),
+ y_train_selec=stats::rnorm(40),
+ X_test=matrix(stats::rnorm(10), nrow=10, ncol=1)),
+ "p >= 2 is not TRUE", fixed=TRUE)
+})## Test passed with 46 successes.A length-1 train_inds used to collapse X_train_selec[train_inds, ] to a
vector, tripping getModelSize’s cryptic is.matrix(X) | is.data.frame(X)
assertion. With drop = FALSE it stays a one-row matrix and the error instead
points informatively at the data (issue #153, item f).
testthat::test_that("cssPredict: length-1 train_inds no longer hits the cryptic is.matrix assertion (#153f)", {
- 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)
-
- # A length-1 train_inds leaves a single training row, so getModelSize's glmnet
- # cross-validation fails informatively on a constant response -- NOT with the
- # old cryptic is.matrix stopifnot from the dropped-to-vector subset. Warnings
- # (e.g. glmnet convergence) are suppressed so we assert on the stop() message.
- err <- tryCatch(
- suppressWarnings(
- cssPredict(X_train_selec = X[1:20, ], y_train_selec = y[1:20],
- X_test = X[41:60, ], clusters = clusters, lambda = 0.01,
- train_inds = 1L)),
- error = function(e) conditionMessage(e))
- testthat::expect_type(err, "character")
- testthat::expect_true(
- grepl("y is constant; gaussian glmnet fails at standardization step", err,
- fixed = TRUE))
- testthat::expect_false(
- grepl("is.matrix(X) | is.data.frame(X) is not TRUE", err, fixed = TRUE))
-})testthat::test_that("cssPredict: length-1 train_inds no longer hits the cryptic is.matrix assertion (#153f)", {
+ 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)
+
+ # A length-1 train_inds leaves a single training row, so getModelSize's glmnet
+ # cross-validation fails informatively on a constant response -- NOT with the
+ # old cryptic is.matrix stopifnot from the dropped-to-vector subset. Warnings
+ # (e.g. glmnet convergence) are suppressed so we assert on the stop() message.
+ err <- tryCatch(
+ suppressWarnings(
+ cssPredict(X_train_selec = X[1:20, ], y_train_selec = y[1:20],
+ X_test = X[41:60, ], clusters = clusters, lambda = 0.01,
+ train_inds = 1L)),
+ error = function(e) conditionMessage(e))
+ testthat::expect_type(err, "character")
+ testthat::expect_true(
+ grepl("y is constant; gaussian glmnet fails at standardization step", err,
+ fixed = TRUE))
+ testthat::expect_false(
+ grepl("is.matrix(X) | is.data.frame(X) is not TRUE", err, fixed = TRUE))
+})## Test passed with 3 successes.cssPredict():
#' Wrapper function to generate predictions from cluster stability selected
#' model in one step
@@ -335,160 +339,168 @@
#' of cutoff, max_num_clusts, etc. by using the calculations done in one call to
#' css.
#'
-#' @param X_train_selec An n x p numeric matrix (preferably) or a data.frame
-#' (which will be coerced internally to a matrix by the function model.matrix)
-#' containing the p >= 2 features/predictors. The data from X_train_selec and
-#' y_train_selec will be split into two parts; half of the data will be used for
-#' feature selection by cluster stability selection, and half will be used for
-#' estimating a linear model on the selected cluster representatives. Must not
-#' contain missing (`NA`) values.
-#' @param y_train_selec A length-n numeric vector containing the responses;
-#' `y[i]` is the response corresponding to observation `X[i, ]`. Unlike the more
-#' general setup of css, y_train_selec must be real-valued because predictions
-#' will be generated by ordinary least squares.
-#' @param X_test A numeric matrix (preferably) or a data.frame (which will
-#' be coerced internally to a matrix by the function model.matrix) containing
-#' the data that will be used to generate predictions. Must contain the same
-#' features (in the same number of columns) as X_train_selec, and if the columns
-#' of X_test are named, they must match the names of X_train_selec.
-#' @param clusters Optional; either an integer vector of a list of integer
-#' vectors; each vector should contain the indices of a cluster of features (a
-#' subset of 1:p). (If there is only one cluster, clusters can either be a list
-#' of length 1 or an integer vector.) All of the provided clusters must be
-#' non-overlapping. Any identical (duplicated) clusters will be removed, keeping
-#' the first occurrence and its name. Every feature not appearing in any cluster
-#' will be assumed
-#' to be unclustered (that is, they will be treated as if they are in a
-#' "cluster" containing only themselves). If clusters is a list of length 0 (or
-#' a list only containing clusters of length 1), then css() returns the same
-#' results as stability selection (so feat_sel_mat will be identical to
-#' clus_sel_mat). Names for the clusters will be needed later; any clusters that
-#' are not given names in the list clusters will be given names automatically by
-#' css. CAUTION: if the provided X_train_selec (or X_test) is a data.frame that
-#' contains a categorical
-#' feature with more than two levels, then the resulting matrix made from
-#' model.matrix will have a different number of columns than the provided
-#' data.frame, some of the feature numbers will change, and the clusters
-#' argument will not work properly (in the current version of the package). To
-#' get correct results in this case, please use model.matrix to convert the
-#' data.frame to a numeric matrix on your own, then provide this matrix and
-#' cluster assignments with respect to this matrix.Default is list() (so no
-#' clusters are specified, and every feature is assumed to be in a "cluster"
-#' containing only itself).
-#' @param lambda Optional; the tuning parameter to be used by the lasso for
-#' feature selection in each subsample. If lambda is not provided, cssPredict
-#' will choose one automatically by cross-validation. Default is NA.
-#' @param cutoff Numeric; cssPredict will make use only of those clusters with
-#' selection proportions equal to at least cutoff. Must be between 0 and 1.
-#' Default is NA (in which case, if auto_select_size is TRUE (the default), the
-#' number of cluster representatives is chosen automatically by cross-validation;
-#' see auto_select_size).
-#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
-#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
-#' max_num_clusts clusters, the cutoff will be raised until at most
-#' max_num_clusts clusters are selected.) Default is NA (in which case
-#' max_num_clusts is ignored). Because clusters can have tied selection
-#' proportions, ties at the threshold can cause more than max_num_clusts (or
-#' fewer than min_num_clusts) clusters to be returned; when the two constraints
-#' conflict, max_num_clusts takes precedence.
-#' @param train_inds Optional; an integer or numeric vector containing the
-#' indices of observations in X_train_selec and y_train_selec to set aside for
-#' model training after
-#' feature selection. If train_inds is not provided, half of the data will be
-#' used for feature selection and half for model estimation (chosen at random).
-#' @param auto_select_size Logical; if TRUE, then max_num_clusts will be
-#' automatically estimated using the lasso with cross-validation. Default is
-#' TRUE, though this argument is ignored if either cutoff or max_num_clusts is
-#' provided. (If desired output is to generate predictions using all clusters,
-#' you should set auto_select_size to FALSE and do not provide cutoff or
-#' max_num_clusts.)
-#' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`.
-#' Drives both the choice of lambda (when lambda is not provided) and the
-#' elastic net fit used for feature selection in each subsample. Default is 1
-#' (in which case the penalty is the lasso).
-#' @return A numeric vector of length nrow(X_test) of predictions
-#' corresponding to the observations from X_test.
-#' @author Gregory Faletto, Jacob Bien
-#' @examples
-#' set.seed(1)
-#' train <- genClusteredData(n = 80, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' test <- genClusteredData(n = 10, p = 11, k_unclustered = 2,
-#' cluster_size = 4, n_clusters = 1, snr = 3)
-#' clusters <- list(cluster1 = 1:4)
-#' preds <- cssPredict(X_train_selec = train$X, y_train_selec = train$y,
-#' X_test = test$X, clusters = clusters)
-#' preds
-#' @export
-cssPredict <- function(X_train_selec, y_train_selec, X_test, clusters=list(),
- lambda=NA, cutoff=NA, max_num_clusts=NA, train_inds=NA,
- auto_select_size=TRUE, alpha=1){
-
- # Check inputs (most inputs will be checked by called functions)
- if(!is.numeric(y_train_selec) & !is.integer(y_train_selec)){
- stop("The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.")
- }
-
- stopifnot(!is.na(auto_select_size))
- stopifnot(length(auto_select_size) == 1)
- stopifnot(is.logical(auto_select_size))
-
- # Validate alpha up front (before the NA-lambda branch and bundling below);
- # see cssSelect for the ordering rationale.
- checkAlpha(alpha)
+#' cssPredict uses "weighted_avg" weighting: each selected cluster is
+#' represented by a weighted average of the cluster members that were selected
+#' on at least one subsample, with weights proportional to their individual
+#' selection proportions.
+#' (Exception: if no member of a selected cluster was selected on any
+#' subsample, the weights fall back to a simple average, so all of that
+#' cluster's members contribute to the representative.)
+#'
+#' @param X_train_selec An n x p numeric matrix (preferably) or a data.frame
+#' (which will be coerced internally to a matrix by the function model.matrix)
+#' containing the p >= 2 features/predictors. The data from X_train_selec and
+#' y_train_selec will be split into two parts; half of the data will be used for
+#' feature selection by cluster stability selection, and half will be used for
+#' estimating a linear model on the selected cluster representatives. Must not
+#' contain missing (`NA`) values.
+#' @param y_train_selec A length-n numeric vector containing the responses;
+#' `y[i]` is the response corresponding to observation `X[i, ]`. Unlike the more
+#' general setup of css, y_train_selec must be real-valued because predictions
+#' will be generated by ordinary least squares.
+#' @param X_test A numeric matrix (preferably) or a data.frame (which will
+#' be coerced internally to a matrix by the function model.matrix) containing
+#' the data that will be used to generate predictions. Must contain the same
+#' features (in the same number of columns) as X_train_selec, and if the columns
+#' of X_test are named, they must match the names of X_train_selec.
+#' @param clusters Optional; either an integer vector of a list of integer
+#' vectors; each vector should contain the indices of a cluster of features (a
+#' subset of 1:p). (If there is only one cluster, clusters can either be a list
+#' of length 1 or an integer vector.) All of the provided clusters must be
+#' non-overlapping. Any identical (duplicated) clusters will be removed, keeping
+#' the first occurrence and its name. Every feature not appearing in any cluster
+#' will be assumed
+#' to be unclustered (that is, they will be treated as if they are in a
+#' "cluster" containing only themselves). If clusters is a list of length 0 (or
+#' a list only containing clusters of length 1), then css() returns the same
+#' results as stability selection (so feat_sel_mat will be identical to
+#' clus_sel_mat). Names for the clusters will be needed later; any clusters that
+#' are not given names in the list clusters will be given names automatically by
+#' css. CAUTION: if the provided X_train_selec (or X_test) is a data.frame that
+#' contains a categorical
+#' feature with more than two levels, then the resulting matrix made from
+#' model.matrix will have a different number of columns than the provided
+#' data.frame, some of the feature numbers will change, and the clusters
+#' argument will not work properly (in the current version of the package). To
+#' get correct results in this case, please use model.matrix to convert the
+#' data.frame to a numeric matrix on your own, then provide this matrix and
+#' cluster assignments with respect to this matrix.Default is list() (so no
+#' clusters are specified, and every feature is assumed to be in a "cluster"
+#' containing only itself).
+#' @param lambda Optional; the tuning parameter to be used by the lasso for
+#' feature selection in each subsample. If lambda is not provided, cssPredict
+#' will choose one automatically by cross-validation. Default is NA.
+#' @param cutoff Numeric; cssPredict will make use only of those clusters with
+#' selection proportions equal to at least cutoff. Must be between 0 and 1.
+#' Default is NA (in which case, if auto_select_size is TRUE (the default), the
+#' number of cluster representatives is chosen automatically by cross-validation;
+#' see auto_select_size).
+#' @param max_num_clusts Integer or numeric; the maximum number of clusters to
+#' use regardless of cutoff. (That is, if the chosen cutoff returns more than
+#' max_num_clusts clusters, the cutoff will be raised until at most
+#' max_num_clusts clusters are selected.) Default is NA (in which case
+#' max_num_clusts is ignored). Because clusters can have tied selection
+#' proportions, ties at the threshold can cause more than max_num_clusts (or
+#' fewer than min_num_clusts) clusters to be returned; when the two constraints
+#' conflict, max_num_clusts takes precedence.
+#' @param train_inds Optional; an integer or numeric vector containing the
+#' indices of observations in X_train_selec and y_train_selec to set aside for
+#' model training after
+#' feature selection. If train_inds is not provided, half of the data will be
+#' used for feature selection and half for model estimation (chosen at random).
+#' @param auto_select_size Logical; if TRUE, then max_num_clusts will be
+#' automatically estimated using the lasso with cross-validation. Default is
+#' TRUE, though this argument is ignored if either cutoff or max_num_clusts is
+#' provided. (If desired output is to generate predictions using all clusters,
+#' you should set auto_select_size to FALSE and do not provide cutoff or
+#' max_num_clusts.)
+#' @param alpha Numeric; the elastic net mixing parameter. Must be in `(0, 1]`.
+#' Drives both the choice of lambda (when lambda is not provided) and the
+#' elastic net fit used for feature selection in each subsample. Default is 1
+#' (in which case the penalty is the lasso).
+#' @return A numeric vector of length nrow(X_test) of predictions
+#' corresponding to the observations from X_test.
+#' @author Gregory Faletto, Jacob Bien
+#' @examples
+#' set.seed(1)
+#' train <- genClusteredData(n = 80, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' test <- genClusteredData(n = 10, p = 11, k_unclustered = 2,
+#' cluster_size = 4, n_clusters = 1, snr = 3)
+#' clusters <- list(cluster1 = 1:4)
+#' preds <- cssPredict(X_train_selec = train$X, y_train_selec = train$y,
+#' X_test = test$X, clusters = clusters)
+#' preds
+#' @export
+cssPredict <- function(X_train_selec, y_train_selec, X_test, clusters=list(),
+ lambda=NA, cutoff=NA, max_num_clusts=NA, train_inds=NA,
+ auto_select_size=TRUE, alpha=1){
+
+ # Check inputs (most inputs will be checked by called functions)
+ if(!is.numeric(y_train_selec) & !is.integer(y_train_selec)){
+ stop("The provided y_train_selec must be real-valued, because predictions will be generated by ordinary least squares regression.")
+ }
- stopifnot(is.matrix(X_train_selec) | is.data.frame(X_train_selec))
- checkNoNAs(X_train_selec, "X_train_selec")
- # Reject a non-finite y on the default path (lands after the numeric check
- # at the top of the function, so the factor-y message there is preserved).
- checkFiniteY(y_train_selec, "y_train_selec")
-
- # Check if x is a matrix; if it's a data.frame, convert to matrix.
- X_train_selec <- coerceDataFrameToMatrix(X_train_selec, clusters,
- arg_name = "X_train_selec")
-
- stopifnot(is.matrix(X_train_selec))
-
- n <- nrow(X_train_selec)
+ stopifnot(!is.na(auto_select_size))
+ stopifnot(length(auto_select_size) == 1)
+ stopifnot(is.logical(auto_select_size))
+
+ # Validate alpha up front (before the NA-lambda branch and bundling below);
+ # see cssSelect for the ordering rationale.
+ checkAlpha(alpha)
+
+ stopifnot(is.matrix(X_train_selec) | is.data.frame(X_train_selec))
+ checkNoNAs(X_train_selec, "X_train_selec")
+ # Reject a non-finite y on the default path (lands after the numeric check
+ # at the top of the function, so the factor-y message there is preserved).
+ checkFiniteY(y_train_selec, "y_train_selec")
- if(any(is.na(train_inds))){
- train_inds <- sample(n, size=round(n/2))
- }
+ # Check if x is a matrix; if it's a data.frame, convert to matrix.
+ X_train_selec <- coerceDataFrameToMatrix(X_train_selec, clusters,
+ arg_name = "X_train_selec")
- stopifnot(length(lambda) == 1)
- if(is.na(lambda)){
- lambda <- getLassoLambda(
- X_train_selec[setdiff(1:n, train_inds), , drop = FALSE],
- y_train_selec[setdiff(1:n, train_inds)], alpha=alpha)
- }
-
- # Bundle alpha into lambda for the elastic-net fit. When alpha == 1 (the
- # default), leave lambda as a scalar so the pure-lasso path is byte-identical
- # to the original behavior.
- if(alpha != 1){
- lambda <- c(lambda=lambda, alpha=alpha)
- }
-
- css_results <- css(X=X_train_selec, y=y_train_selec, lambda=lambda,
- clusters=clusters, train_inds=train_inds)
-
- # If no indication of how to select model size was provided, choose model
- # size by cross-validation
- if(is.na(cutoff) & is.na(max_num_clusts)){
- if(auto_select_size){
- max_num_clusts <- getModelSize(X_train_selec[train_inds, , drop = FALSE],
- y_train_selec[train_inds], css_results$clusters, alpha=alpha)
- }
- }
-
- if(is.na(cutoff)){
- cutoff <- 0
- }
-
- # Get predictions
- getCssPreds(css_results, testX=X_test, weighting="weighted_avg",
- cutoff=cutoff, max_num_clusts=max_num_clusts)
-}
getCssDesign() and getCssPreds(): under "sparse" weighting a tie divides the weight equally among the tied members of a cluster, not among the tied clusters, as the text had said. cssSelect() and cssPredict() now also state which weighting each of them uses and what that means for what they return, and getCssDesign() and getCssPreds() now carry the exception clause getCssSelections() already published, for the case where no member of a selected cluster was selected on any subsample. Documentation only; no behavior changed (#203).
This file starts here rather than covering the package’s whole history; for changes before this point, see the closed pull requests and the commit log.
diff --git a/docs/news/index.md b/docs/news/index.md index ab9f72ff..be6fc109 100644 --- a/docs/news/index.md +++ b/docs/news/index.md @@ -57,6 +57,28 @@ rely on warnings to notice a change, since there is nothing to catch. +- Corrected the `weighting` documentation on + [`getCssSelections()`](https://gregfaletto.github.io/cssr-project/reference/getCssSelections.md), + [`getCssDesign()`](https://gregfaletto.github.io/cssr-project/reference/getCssDesign.md) + and + [`getCssPreds()`](https://gregfaletto.github.io/cssr-project/reference/getCssPreds.md): + under `"sparse"` weighting a tie divides the weight equally among the + tied members of a cluster, not among the tied clusters, as the text + had said. + [`cssSelect()`](https://gregfaletto.github.io/cssr-project/reference/cssSelect.md) + and + [`cssPredict()`](https://gregfaletto.github.io/cssr-project/reference/cssPredict.md) + now also state which weighting each of them uses and what that means + for what they return, and + [`getCssDesign()`](https://gregfaletto.github.io/cssr-project/reference/getCssDesign.md) + and + [`getCssPreds()`](https://gregfaletto.github.io/cssr-project/reference/getCssPreds.md) + now carry the exception clause + [`getCssSelections()`](https://gregfaletto.github.io/cssr-project/reference/getCssSelections.md) + already published, for the case where no member of a selected cluster + was selected on any subsample. Documentation only; no behavior changed + ([\#203](https://github.com/gregfaletto/cssr-project/issues203)). + This file starts here rather than covering the package’s whole history; for changes before this point, see the closed pull requests and the commit log. diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index 98beec5b..73f3bbd3 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -5,7 +5,7 @@ articles: advanced-usage: advanced-usage.html exploring-results: exploring-results.html prediction: prediction.html -last_built: 2026-09-09T02:03Z +last_built: 2026-09-10T22:21Z urls: reference: https://gregfaletto.github.io/cssr-project/reference article: https://gregfaletto.github.io/cssr-project/articles diff --git a/docs/reference/cssPredict.html b/docs/reference/cssPredict.html index 559523c8..80a37b60 100644 --- a/docs/reference/cssPredict.html +++ b/docs/reference/cssPredict.html @@ -191,6 +191,16 @@A numeric vector of length nrow(X_test) of predictions corresponding to the observations from X_test.
+ +cssPredict uses "weighted_avg" weighting: each selected cluster is +represented by a weighted average of the cluster members that were selected +on at least one subsample, with weights proportional to their individual +selection proportions. +(Exception: if no member of a selected cluster was selected on any +subsample, the weights fall back to a simple average, so all of that +cluster's members contribute to the representative.)
A named integer vector; the indices of the features with nonzero weights from all of the selected -clusters.
A named list of the same length as selected_clusts.
Each list element weights[[j]] is a numeric vector of the weights to use for
the jth selected cluster, and it has the same name as the cluster it
diff --git a/docs/reference/cssSelect.md b/docs/reference/cssSelect.md
index bf74e06e..78acb441 100644
--- a/docs/reference/cssSelect.md
+++ b/docs/reference/cssSelect.md
@@ -122,7 +122,11 @@ A named list with three items.
- selected_feats:
A named integer vector; the indices of the features with nonzero
- weights from all of the selected clusters.
+ weights from all of the selected clusters. cssSelect uses "sparse"
+ weighting, so a selected cluster contributes the member with the
+ highest individual selection proportion, along with every other member
+ of that cluster tied with it at that maximum. A selected cluster can
+ therefore contribute more than one feature.
- weights:
diff --git a/docs/reference/getCssDesign.html b/docs/reference/getCssDesign.html
index 11641f33..fe294a0e 100644
--- a/docs/reference/getCssDesign.html
+++ b/docs/reference/getCssDesign.html
@@ -89,10 +89,14 @@