diff --git a/DESCRIPTION b/DESCRIPTION index b8359daa..87090b36 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -63,5 +63,5 @@ biocViews: ImmunoOncology, MultipleComparison, Classification, Regression -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.0 Encoding: UTF-8 diff --git a/R/MCV.block.splsda.R b/R/MCV.block.splsda.R index ae3d46ac..7d0df56e 100644 --- a/R/MCV.block.splsda.R +++ b/R/MCV.block.splsda.R @@ -115,12 +115,12 @@ MCVfold.block.splsda <- # prediction of all samples for each test.keepX and nrep at comp fixed folds.input = folds + n = nrow(X[[1]]) + repeated.measure = 1:n + #-- define the folds --# if (validation == "Mfold") { - n = nrow(X[[1]]) - repeated.measure = 1:n - if (is.null(folds) || !is.numeric(folds) || folds < 2 || folds > n) { stop("Invalid number of folds.") diff --git a/R/network.R b/R/network.R index 1092b6e9..929732da 100644 --- a/R/network.R +++ b/R/network.R @@ -813,7 +813,7 @@ network <- function(mat, #-- check cutoff if (round(max(abs(w)), 2) == 0) - stop("There is no correlation between these blocks whith these components.", + stop("There is no correlation between these blocks with these components.", "Try a different value of 'comp'.", call. = FALSE) if (!is.numeric(cutoff) || cutoff < 0 || cutoff > 1) diff --git a/R/pca.R b/R/pca.R index 6866772b..39b5d550 100644 --- a/R/pca.R +++ b/R/pca.R @@ -147,9 +147,13 @@ pca <- function(X, if (is.null(ncomp)) ncomp = min(nrow(X), ncol(X)) + if (!is.numeric(ncomp)) { + stop("`ncomp` must be numeric", call. = FALSE) + } + ncomp = round(ncomp) - if (!is.numeric(ncomp) || ncomp < 1 || !is.finite(ncomp)) + if (ncomp < 1 || !is.finite(ncomp)) stop("invalid value for 'ncomp'.", call. = FALSE) if (ncomp > min(ncol(X), nrow(X))) diff --git a/inst/testdata/testdata-auroc.rda b/inst/testdata/testdata-auroc.rda new file mode 100644 index 00000000..e1562ede Binary files /dev/null and b/inst/testdata/testdata-auroc.rda differ diff --git a/inst/testdata/testdata-background.predict.rda b/inst/testdata/testdata-background.predict.rda new file mode 100644 index 00000000..fef02861 Binary files /dev/null and b/inst/testdata/testdata-background.predict.rda differ diff --git a/inst/testdata/testdata-cim.rda b/inst/testdata/testdata-cim.rda new file mode 100644 index 00000000..626c017e Binary files /dev/null and b/inst/testdata/testdata-cim.rda differ diff --git a/inst/testdata/testdata-circosPlot.rda b/inst/testdata/testdata-circosPlot.rda new file mode 100644 index 00000000..5834b428 Binary files /dev/null and b/inst/testdata/testdata-circosPlot.rda differ diff --git a/inst/testdata/testdata-diablo.rda b/inst/testdata/testdata-diablo.rda new file mode 100644 index 00000000..d8e51acf Binary files /dev/null and b/inst/testdata/testdata-diablo.rda differ diff --git a/inst/testdata/testdata-network.rda b/inst/testdata/testdata-network.rda new file mode 100644 index 00000000..c93a1c47 Binary files /dev/null and b/inst/testdata/testdata-network.rda differ diff --git a/inst/testdata/testdata-pca.rda b/inst/testdata/testdata-pca.rda new file mode 100644 index 00000000..082a43d8 Binary files /dev/null and b/inst/testdata/testdata-pca.rda differ diff --git a/inst/testdata/testdata-perf.diablo.rda b/inst/testdata/testdata-perf.diablo.rda new file mode 100644 index 00000000..abaadf18 Binary files /dev/null and b/inst/testdata/testdata-perf.diablo.rda differ diff --git a/inst/testdata/testdata-perf.mint.splsda.rda b/inst/testdata/testdata-perf.mint.splsda.rda new file mode 100644 index 00000000..61b13c60 Binary files /dev/null and b/inst/testdata/testdata-perf.mint.splsda.rda differ diff --git a/inst/testdata/testdata-plotIndiv.rda b/inst/testdata/testdata-plotIndiv.rda new file mode 100644 index 00000000..445c1f0c Binary files /dev/null and b/inst/testdata/testdata-plotIndiv.rda differ diff --git a/inst/testdata/testdata-plotLoadings.rda b/inst/testdata/testdata-plotLoadings.rda new file mode 100644 index 00000000..9a1b5f44 Binary files /dev/null and b/inst/testdata/testdata-plotLoadings.rda differ diff --git a/inst/testdata/testdata-plotVar.rda b/inst/testdata/testdata-plotVar.rda new file mode 100644 index 00000000..39053e10 Binary files /dev/null and b/inst/testdata/testdata-plotVar.rda differ diff --git a/inst/testdata/testdata-predict.rda b/inst/testdata/testdata-predict.rda new file mode 100644 index 00000000..20acab03 Binary files /dev/null and b/inst/testdata/testdata-predict.rda differ diff --git a/inst/testdata/testdata-tune.block.splsda.rda b/inst/testdata/testdata-tune.block.splsda.rda new file mode 100644 index 00000000..4d12fca4 Binary files /dev/null and b/inst/testdata/testdata-tune.block.splsda.rda differ diff --git a/inst/testdata/testdata-tune.mint.splsda.rda b/inst/testdata/testdata-tune.mint.splsda.rda new file mode 100644 index 00000000..33be36b2 Binary files /dev/null and b/inst/testdata/testdata-tune.mint.splsda.rda differ diff --git a/inst/testdata/testdata-tune.splsda.rda b/inst/testdata/testdata-tune.splsda.rda new file mode 100644 index 00000000..5e48f432 Binary files /dev/null and b/inst/testdata/testdata-tune.splsda.rda differ diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R index db4b3f11..d52ba35c 100644 --- a/tests/testthat/helpers.R +++ b/tests/testthat/helpers.R @@ -24,3 +24,190 @@ require(testthat) expect_equal(round(numeric_value, digits = digits), round(expected, digits = digits)) } + + +#' From input X and Y dataframes, yields the smallest set of training and testing +#' samples to remain valid for any mixOmics method. Caters sample selection to +#' if method requires multiblock, multigroup or multilevel frameworks. +#' +#' @param X X dataframe for any mixOmics method. Can be a list of multiple dataframes if multiblock +#' @param Y Y dataframe or factor vector for any mixOmics method +#' @param S study factor vector for multigroup frameworks +#' @param ML repreated measures vector for multilevel frameworks +#' @param n.tr number of training samples (per class if DA) +#' @param n.te number of testing samples (per class if DA) +#' @param seed controls the sample selection seed +#' @return list of X, Y, study and multilevel components split by training and testing samples +#' @keywords internal +.minimal_train_test_subset <- function(X=NULL, + Y=NULL, + S=NULL, + ML=NULL, + n.tr=2, + n.te=1, + seed=16) { + set.seed(seed) + + DA = is.factor(Y) # logical gate for DA framework + MULTIGROUP = !is.null(S) # logical gate for multigroup framework + MULTILEVEL = !is.null(ML) # logical gate for multilevel framework + MULTIBLOCK = !is.data.frame(X) && !is.matrix(X) # logical gate for multiblock framework + + tr <- c() # initialise indicies for training and testing samples + te <- c() + + if (MULTILEVEL) { # any multilevel method + + n.indivs <- 3 # default number of repeated samples to consider + + #if(DA) { n.indivs <- length(unique(Y))-1 } # if DA, set specific quantity + + # only look at the first n.indiv samples were measured the maximum amount of times + indivs <- unname(which(table(ML) == max(table(ML))))[1:n.indivs] + + for (i in 1:length(indivs)) { # for each repeated sample ... + s <- indivs[i] + + rel.sam <- which(ML==s) # determine the corresponding rows + tr.sam <- sample(rel.sam, n.tr, F) # take n.tr of these for training (1:n.tr+(i-1)) + te.sam <- setdiff(rel.sam, tr.sam) # and take n.te of these for testing + + tr <- c(tr, tr.sam) + te <- c(te, te.sam) + + } + } + else if(DA) { # if the framework is DA ... + + for(c in unique(Y)) { # for each class ... + + if (MULTIGROUP) { # MINT.(s)PLSDA + for (s in unique(S)){ # for each study ... + # determine the rows with that class and for that study + rel.sam <- intersect(which(Y==c), which(S==s)) + tr <- c(tr, rel.sam[1:n.tr]) # take first n.tr samples for training + # if that samples's class and study is not already present in testing, add it + if (!(s %in% S[te] || c %in% Y[te])) {te <- c(te, rel.sam[(n.tr+1):(n.tr+n.te)]) } # THIS WILL FUCK UP !!!!!!!!!!!!!!!!! + } + } else { # (BLOCK).(s)PLSDA + rows <- which(Y == c) + tr <- c(tr, rows[1:n.tr+1]) + te <- c(te, rows[(n.tr+1):(n.tr+n.te)]) + } + + } + + if (MULTIGROUP) { # ensure that all studies in training are present in testing + tr.te.study.diff <- setdiff(unique(S[tr]), unique(S[te])) + if (length(tr.te.study.diff) != 0) { + for (s in tr.te.study.diff) { + te <- c(te, which(S == s)[1]) # THIS WILL FUCK UP !!!!!!!!!!!!!!!!! + } + } + } + + } + else { + if (MULTIGROUP) { # MINT.(S)PLS + for (s in unique(S)){ + rel.sam <- which(S==s) + tr <- c(tr, rel.sam[1:n.tr]) + te <- c(te, rel.sam[(n.tr+1):(n.tr+n.te)]) + } + } else { # (BLOCK).(s)PLS + tr <- 1:n.tr + te <- (n.tr+1):(n.tr+n.te) + } + } + + + + if(MULTIBLOCK) { # subset each block iteratively if multiblock + X.tr <- list() + X.te <- list() + + for (block in names(X)) { + X.tr[[block]] <- X[[block]][tr,] + X.te[[block]] <- X[[block]][te,] + } + } else { # otherwise just subset X + X.tr <- X[tr, ] + X.te <- X[te, ] + } + + if (DA) { # if Y is a factor, index list + Y.tr <- Y[tr] + Y.te <- Y[te] + } else { # if Y is a data.frame, index df + Y.tr <- Y[tr,] + Y.te <- Y[te,] + } + + out <- list(X.tr = X.tr, + X.te = X.te, + Y.tr = Y.tr, + Y.te = Y.te) + + if (MULTILEVEL) { # include repeated measures + out$ML.tr <- ML[tr] + out$ML.te <- ML[te] + } + + if (MULTIGROUP) { # include study + out$S.tr <- as.factor(S[tr]) + out$S.te <- as.factor(S[te]) + } + + + return(out) +} + + +.quiet <- function(x) { + sink(tempfile()) + on.exit(sink()) + invisible(force(x)) +} + + +.gt.homogeneity <- function(items) { + + novel.items <- list() + novel.items["basic"] <- items[1] + + for (idx in 2:length(items)) { + + i <- items[[idx]] + novel<-T + + for (n.i in novel.items) { + if (setequal(i, n.i)) { + novel<-F + } + } + + if (novel) { + novel.items[[names(items)[idx]]] <- i + } + } + + homo.list <- list() + for (n.i in names(novel.items)) { + homo.list[[n.i]] <- vector() + } + + for (n.i.idx in 1:length(novel.items)) { + n.i <- novel.items[n.i.idx] + for (i.idx in 1:length(items)) { + i <- items[i.idx] + if (setequal(i, n.i)) { + homo.list[[n.i.idx]] <- c(homo.list[[n.i.idx]], names(items)[i.idx]) + } + } + } + + return(list(novel.items=novel.items, + homo.list=homo.list)) +} + + diff --git a/tests/testthat/test-auroc.R b/tests/testthat/test-auroc.R index e0d02a80..82351e0b 100644 --- a/tests/testthat/test-auroc.R +++ b/tests/testthat/test-auroc.R @@ -1,22 +1,417 @@ -context("auroc") -test_that("auroc works", { +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# basic +## mint.block.plsda +## mint.block.splsda - created a node within the Project workflow. Once addressed, add tests + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-auroc.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + + +test_that("(auroc:basic): (s)plsda", { + + testable.components <- Testable.Components$basic + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + # --- PLS-DA -- # + GT <- Ground.Truths$basic.plsda + + res.plsda <- plsda(X, Y, ncomp = 2) + + plsda.auroc = auroc(res.plsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(plsda.auroc[testable.components]))) + + expect_equal(TT, GT) + + # --- sPLS-DA -- # + GT <- Ground.Truths$basic.splsda + + choice.keepX <- c(10, 10) + + res.splsda <- splsda(X, Y, ncomp = 2, keepX = choice.keepX) + + splsda.auroc = auroc(res.splsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(splsda.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:basic): mint.(s)plsda", { + + testable.components <- Testable.Components$mint + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + s <- stemcells$study + + # --- MINT.PLS-DA -- # + GT <- Ground.Truths$basic.mint.plsda + + res.mint.plsda <- mint.plsda(X, Y, ncomp = 2, study = s) + + mint.plsda.auroc = auroc(res.mint.plsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(mint.plsda.auroc[testable.components]))) + + expect_equal(TT, GT) + + # --- MINT.sPLS-DA -- # + GT <- Ground.Truths$basic.mint.splsda + + choice.keepX <- c(10,10) + + res.mint.splsda <- mint.splsda(X, Y, ncomp = 2, study = s, keepX = choice.keepX) + + mint.splsda.auroc = auroc(res.mint.splsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(mint.splsda.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:basic): block.(s)plsda", { + + testable.components <- Testable.Components$block + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + # --- BLOCK.PLS-DA -- # + GT <- Ground.Truths$basic.block.plsda + + res.block.plsda <- block.plsda(X, Y, design = "full") + + block.plsda.auroc = auroc(res.block.plsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(block.plsda.auroc[testable.components]))) + + expect_equal(TT, GT) + + # --- BLOCK.sPLS-DA -- # + GT <- Ground.Truths$basic.block.splsda + + choice.keepX <- list(miRNA=c(10,10), + mRNA=c(10,10), + proteomics=c(10,10)) + + res.block.splsda <- block.splsda(X, Y, design = "full", keepX = choice.keepX) + + block.splsda.auroc = auroc(res.block.splsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(block.splsda.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(auroc:data): splsda, srbct", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$srbct.splsda + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + choice.keepX <- c(10, 10) + + res.splsda <- splsda(X, Y, ncomp = 2, keepX = choice.keepX) + + srbct.splsda.auroc = auroc(res.splsda, roc.comp = 1, print = FALSE) + + invisible(capture.output(TT <- dput(srbct.splsda.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================= PARAMETER =============================== ### +############################################################################### + + +test_that("(auroc:parameter): newdata/outcome.test", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$newdata.splsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + d <- .minimal_train_test_subset(X, as.factor(Y), n.tr = 15, n.te = 3) + + res.plsda <- plsda(d$X.tr, d$Y.tr, ncomp = 2) + + newdata.outcome.test.auroc = auroc(res.plsda, print = FALSE, roc.comp = 1, + newdata = d$X.te, outcome.test = d$Y.te) + + invisible(capture.output(TT <- dput(newdata.outcome.test.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:parameter): multilevel", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$multilevel.splsda + + data(diverse.16S) + X <- diverse.16S$data.TSS + Y <- diverse.16S$bodysite + mL <- diverse.16S$sample + + res.plsda <- plsda(X, Y, ncomp = 2) + + multilevel.auroc <- auroc(res.plsda, print = FALSE, roc.comp = 2, + multilevel = mL) + + invisible(capture.output(TT <- dput(multilevel.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:parameter): roc.comp", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$basic.plsda + data(breast.tumors) - set.seed(1) - test=sample(1:47,5,replace=FALSE) X <- breast.tumors$gene.exp - X.test<-breast.tumors$gene.exp[test,] Y <- breast.tumors$sample$treatment - Y.test<-breast.tumors$sample$treatment[test] + + res.plsda <- plsda(X, Y, ncomp = 2) + + roc.comp.auroc = auroc(res.plsda, roc.comp = 2, print = FALSE) + + invisible(capture.output(TT <- dput(roc.comp.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:parameter): roc.study", { + testable.components <- Testable.Components$study + GT <- Ground.Truths$roc.study.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + s <- stemcells$study + + res.mint.plsda <- mint.plsda(X, Y, ncomp = 2, study = s) + + roc.study.mint.splsda = auroc(res.mint.plsda, roc.study = 2, print = FALSE) + + invisible(capture.output(TT <- dput(roc.study.mint.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:parameter): roc.block", { + + testable.components <- Testable.Components$block + GT <- Ground.Truths$basic.block.plsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y, ncomp = 2) + + roc.block.auroc <- auroc(res.block.plsda, roc.block = 2, print = FALSE) + + invisible(capture.output(TT <- dput(roc.block.auroc[testable.components]))) + + expect_equal(TT, GT) + + roc.block.auroc <- auroc(res.block.plsda, roc.block = "mRNA", print = FALSE) + + invisible(capture.output(TT <- dput(roc.block.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(auroc:parameter): study.test", { + + testable.components <- Testable.Components$study + GT <- Ground.Truths$study.test.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S=S) + + res.mint.plsda <- mint.plsda(d$X.tr, d$Y.tr, ncomp = 2, study = d$S.tr) + + study.test.auroc = auroc(res.mint.plsda, print = FALSE, + newdata = d$X.te, outcome.test = d$Y.te, + study.test = d$S.te) + + invisible(capture.output(TT <- dput(study.test.auroc[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(auroc:error): catches invalid `roc.comp` values", { + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + res.plsda <- plsda(X, Y, ncomp = 2) + + expect_error(auroc(res.plsda, roc.comp = c(1,2), print = FALSE), + "roc.comp") + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + res.mint.plsda <- mint.plsda(X, Y, ncomp = 2, study = S) + + expect_error(auroc(res.mint.plsda, roc.comp = c(1,2), print = FALSE), + "roc.comp") +}) + + +test_that("(auroc:error): catches invalid `roc.block` values", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y, ncomp = 2) + + expect_error(auroc(res.block.plsda, roc.block = 4, print = FALSE), + "roc.block") + + expect_error(auroc(res.block.plsda, roc.block = TRUE, print = FALSE), + "roc.block") +}) + + +test_that("(auroc:error): catches invalid `roc.study` values", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + s <- stemcells$study + + res.mint.plsda <- mint.plsda(X, Y, study = s, ncomp = 2) + + expect_error(auroc(res.mint.plsda, roc.study = c(1, 2), print = FALSE), + "roc.study") + + expect_error(auroc(res.mint.plsda, roc.study = "study1", print = FALSE), + "roc.study") +}) + + +test_that("(auroc:error): prevent sgcca and rgcca objects being used", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + + res.rgcca <- wrapper.rgcca(X) + + + expect_error(auroc(res.rgcca, print = FALSE), + "rgcca") + + res.block.pls <- block.pls(X, indY=3) + + expect_error(auroc(res.block.pls, print = FALSE), + "sgcca") +}) + + +test_that("(auroc:error): confirm 'new.data', 'outcome.test' and 'study.test' are all of same length and width", { + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + d <- .minimal_train_test_subset(X, as.factor(Y), n.tr = 15, n.te = 3) + + res.plsda <- plsda(d$X.tr, d$Y.tr, ncomp = 2) + + expect_error(auroc(res.plsda, print = FALSE, roc.comp = 1, + newdata = d$X.te[, 1:500], outcome.test = d$Y.te), + "newdata") + + expect_error(auroc(res.plsda, print = FALSE, roc.comp = 1, + newdata = d$X.te[1:4,], outcome.test = d$Y.te), + "outcome.test") - auc.plsda=auroc(res.plsda,plot = TRUE,roc.comp = 1) + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study - expect_equal(matrix(auc.plsda$Comp1), - rbind(0.863, 2.473e-05)) + d <- .minimal_train_test_subset(X, Y, S=S) + + res.mint.plsda <- mint.plsda(X, Y, ncomp = 2, study = S) + + expect_error(auroc(res.mint.plsda, print = FALSE, roc.comp = 1, + newdata = d$X.te[1:2,], outcome.test = d$Y.te, + study.test = d$S.te), + "outcome.test") + + expect_error(auroc(res.mint.plsda, print = FALSE, roc.comp = 1, + newdata = d$X.te, outcome.test = d$Y.te, + study.test = d$S.te[1:2]), + "study.test") +}) + - expect_equal(matrix(auc.plsda$Comp2), - rbind(0.9981, 7.124e-09)) - }) diff --git a/tests/testthat/test-background.predict.R b/tests/testthat/test-background.predict.R index bfae6502..0f8fbbee 100644 --- a/tests/testthat/test-background.predict.R +++ b/tests/testthat/test-background.predict.R @@ -1,13 +1,250 @@ -context("background.predict") -test_that("background.predict works", code = { +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# basic +## mint.plsda +## mint.splsda + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-background.predict.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(background.predict:basic): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + plsda.bgp = background.predict(res.plsda, comp.predicted = 2, resolution = 10) + + invisible(capture.output(TT <- dput(plsda.bgp[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(background.predict:basic): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + choice.keepX <- c(10, 10) + + res.splsda <- splsda(X, Y, ncomp = 2, keepX = choice.keepX) + + splsda.bgp = background.predict(res.splsda, comp.predicted = 2, resolution = 10) + + invisible(capture.output(TT <- dput(splsda.bgp[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(background.predict:data): liver.toxicity", { + + testable.components <- Testable.Components$liver.toxicity.plsda + GT <- Ground.Truths$liver.toxicity.plsda + data(liver.toxicity) X = liver.toxicity$gene Y = as.factor(liver.toxicity$treatment[, 4]) + + res.plsda <- plsda(X, Y, ncomp = 2) + liver.toxicity.plsda.bgp = background.predict(res.plsda, comp.predicted = 2, resolution = 10) + + invisible(capture.output(TT <- dput(liver.toxicity.plsda.bgp[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(background.predict:data): srbct", { + + testable.components <- Testable.Components$srbct.plsda + GT <- Ground.Truths$srbct.plsda + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + res.plsda <- plsda(X, Y, ncomp = 2) + srbct.plsda.bgp = background.predict(res.plsda, comp.predicted = 2, resolution = 10) + + invisible(capture.output(TT <- dput(srbct.plsda.bgp[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================= PARAMETER =============================== ### +############################################################################### + + +test_that("(background.predict:parameter): comp.predicted", { + + testable.components <- Testable.Components$comp.predicted.plsda + GT <- Ground.Truths$comp.predicted.plsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + comp.predicted.bgp = background.predict(res.plsda, comp.predicted = 1, resolution = 10) - plsda.liver <- plsda(X, Y, ncomp = 2) - background = background.predict(plsda.liver, comp.predicted = 2, dist = "mahalanobis.dist", resolution = 20) + invisible(capture.output(TT <- dput(comp.predicted.bgp[testable.components]))) - expect_is(background, "background.predict") - .expect_numerically_close(background$`6`[1,], c(Var1 = 16.3966070584067, Var2 = -28.7410902930419)) + expect_equal(TT, GT) }) + + +test_that("(background.predict:parameter): dist", { + + testable.components <- Testable.Components$dist.plsda + GT.max <- Ground.Truths$dist.max.plsda + GT.centroids <- Ground.Truths$dist.centroids.plsda + GT.mahalanobis <- Ground.Truths$dist.mahalanobis.plsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + max.dist.bgp = background.predict(res.plsda, comp.predicted = 2, + dist = "max.dist", resolution = 10) + + centroids.dist.bgp = background.predict(res.plsda, comp.predicted = 2, + dist = "centroids.dist", resolution = 10) + + mahalanobis.dist.bgp = background.predict(res.plsda, comp.predicted = 2, + dist = "mahalanobis.dist", resolution = 10) + + invisible(capture.output(TT <- dput(max.dist.bgp[testable.components]))) + expect_equal(TT, GT.max) + + invisible(capture.output(TT <- dput(centroids.dist.bgp[testable.components]))) + expect_equal(TT, GT.centroids) + + invisible(capture.output(TT <- dput(mahalanobis.dist.bgp[testable.components]))) + expect_equal(TT, GT.mahalanobis) +}) + + +test_that("(background.predict:parameter): resolution", { + + testable.components <- Testable.Components$resolution.plsda + GT.20 <- Ground.Truths$resolution.20.plsda + GT.30 <- Ground.Truths$resolution.30.plsda + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + res.20.bgp = background.predict(res.plsda, comp.predicted = 2, + resolution = 20) + + res.30.bgp = background.predict(res.plsda, comp.predicted = 2, + resolution = 30) + + invisible(capture.output(TT <- dput(res.20.bgp[testable.components]))) + expect_equal(TT, GT.20) + + invisible(capture.output(TT <- dput(res.30.bgp[testable.components]))) + expect_equal(TT, GT.30) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + + +test_that("(background.predict:error): cannot use block.(s)plsda objects", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y, design = "full") + + expect_error(background.predict(res.block.plsda), + "'background.predict' can only be calculated for 'plsda' + and 'splsda' objects", + fixed = TRUE) + + choice.keepX <- list(miRNA=c(10,10), + mRNA=c(10,10), + proteomics=c(10,10)) + + res.block.splsda <- block.splsda(X, Y, design = "full", keepX = choice.keepX) + + expect_error(background.predict(res.block.splsda), + "'background.predict' can only be calculated for 'plsda' + and 'splsda' objects", + fixed = TRUE) +}) + + +test_that("(background.predict:error): ensure dist has valid value", { + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + expect_error(background.predict(res.plsda, dist = "incorrect.dist"), + "Choose one of the three following distances: 'max.dist', + 'centroids.dist' or 'mahalanobis.dist'", + fixed = TRUE) + +}) + + +test_that("(background.predict:error): ensure dist has valid value", { + + data(breast.tumors) + X <- breast.tumors$gene.exp + Y <- breast.tumors$sample$treatment + + res.plsda <- plsda(X, Y, ncomp = 2) + + expect_error(background.predict(res.plsda, comp.predicted = 3), + "Can only show predicted background for 1 or 2 components", + fixed = TRUE) +}) + + diff --git a/tests/testthat/test-cim.R b/tests/testthat/test-cim.R index 188cac2a..1d0d2fa1 100644 --- a/tests/testthat/test-cim.R +++ b/tests/testthat/test-cim.R @@ -1,72 +1,528 @@ -test_that("CIM works for matrices", code = { + +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# basic +## pca - once issue #171 is resolved we can do this one + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-cim.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(cim:basic): matrices", { + + testable.components <- Testable.Components$basic.matrix + GT <- Ground.Truths$basic.matrix + data(nutrimouse) - X <- nutrimouse$lipid - Y <- nutrimouse$gene - cim_res <- cim(cor(X, Y), cluster = "none") - expect_is(cim_res[[1]], "matrix") + X <- nutrimouse$lipid[, 1:10] + Y <- nutrimouse$gene[, 1:10] + + matrix.cim <- cim(cor(X, Y), cluster = "none") + + invisible(capture.output(TT <- dput(matrix.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): spca", { + + testable.components <- Testable.Components$basic.spca + GT <- Ground.Truths$basic.spca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10,1:10] + + res.spca <- spca(X, keepX = c(3,3)) + + spca.cim <- cim(res.spca) + + invisible(capture.output(TT <- dput(spca.cim[testable.components]))) + + expect_equal(TT, GT) }) -test_that("CIM works for rcc", code = { + +test_that("(cim:basic): ipca", { + testable.components <- Testable.Components$basic.ipca + GT <- Ground.Truths$basic.ipca + data(nutrimouse) - X <- nutrimouse$lipid - Y <- nutrimouse$gene - nutri.rcc <- rcc(X, Y, ncomp = 3, lambda1 = 0.064, lambda2 = 0.008) - cim_res <- cim(nutri.rcc, xlab = "genes", ylab = "lipids", margins = c(5, 6)) - expect_is(cim_res[[1]], "matrix") + X <- nutrimouse$lipid[1:10,1:10] + + res.ipca <- ipca(X) + + ipca.cim <- cim(res.ipca) + + invisible(capture.output(TT <- dput(ipca.cim[testable.components]))) + + expect_equal(TT, GT) }) -test_that("CIM works for spca", code = { + +test_that("(cim:basic): sipca", { + + testable.components <- Testable.Components$basic.sipca + GT <- Ground.Truths$basic.sipca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10,1:10] + + res.sipca <- sipca(X, ncomp=2, keepX = c(3,3)) + + sipca.cim <- cim(res.sipca) + + invisible(capture.output(TT <- dput(sipca.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): rcc", { + + testable.components <- Testable.Components$basic.rcc + GT <- Ground.Truths$basic.rcc + + data(nutrimouse) + X <- nutrimouse$lipid[,1:10] + Y <- nutrimouse$gene[,1:10] + + res.rcc <- rcc(X, Y, method = "shrinkage") + + rcc.cim <- cim(res.rcc) + + invisible(capture.output(TT <- dput(rcc.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): pls", { + + testable.components <- Testable.Components$basic.pls + GT <- Ground.Truths$basic.pls + data(liver.toxicity) - X <- liver.toxicity$gene - liver.spca <- spca(X, ncomp = 2, keepX = c(30, 30), scale = FALSE) - dose.col <- color.mixo(as.numeric(as.factor(liver.toxicity$treatment[, 3]))) - cim_res <- cim(liver.spca, row.sideColors = dose.col, col.names = FALSE, - row.names = liver.toxicity$treatment[, 3], - clust.method = c("ward", "ward")) - expect_is(cim_res[[1]], "matrix") + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.pls <- pls(X, Y) + + pls.cim <- cim(res.pls) + + invisible(capture.output(TT <- dput(pls.cim[testable.components]))) + + expect_equal(TT, GT) }) -test_that("CIM works for spls", code = { + +test_that("(cim:basic): spls", { + + testable.components <- Testable.Components$basic.spls + GT <- Ground.Truths$basic.spls + data(liver.toxicity) - X <- liver.toxicity$gene - Y <- liver.toxicity$clinic - liver.spls <- spls(X, Y, ncomp = 3, - keepX = c(2, 5, 5), keepY = c(10, 10, 10)) - cim_res <- cim(liver.spls) - expect_is(cim_res[[1]], "matrix") + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3)) + + spls.cim <- cim(res.spls) + + invisible(capture.output(TT <- dput(spls.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + set.seed(16) + samples <- sample(1:63, 10) + + data(srbct) + X <- srbct$gene[samples,1:10] + Y <- srbct$class[samples] + + res.plsda <- plsda(X, Y) + + plsda.cim <- cim(res.plsda) + + invisible(capture.output(TT <- dput(plsda.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + set.seed(16) + samples <- sample(1:63, 10) + + data(srbct) + X <- srbct$gene[samples,1:10] + Y <- srbct$class[samples] + + res.splsda <- splsda(X, Y, keepX = c(3,3)) + + splsda.cim <- cim(res.splsda) + + invisible(capture.output(TT <- dput(splsda.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): ml-spls", { + + testable.components <- Testable.Components$basic.mlspls + GT <- Ground.Truths$basic.mlspls + + data(vac18) + X <- vac18$genes[,1:10] + Y <- vac18$genes[,11:20] + ml <- vac18$sample + + res.mlpls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3), multilevel = ml) + + mlspls.cim <- cim(res.mlpls) + + invisible(capture.output(TT <- dput(mlspls.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): ml-splsda", { + + testable.components <- Testable.Components$basic.mlsplsda + GT <- Ground.Truths$basic.mlsplsda + + data(vac18) + X <- vac18$genes[,1:10] + Y <- vac18$stimulation + ml <- vac18$sample + + res.mlplsda <- splsda(X, Y, keepX = c(3,3), multilevel = ml) + + mlsplsda.cim <- cim(res.mlplsda) + + invisible(capture.output(TT <- dput(mlsplsda.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:basic): mint.spls", { + + testable.components <- Testable.Components$basic.mint.spls + GT <- Ground.Truths$basic.mint.spls + + data(stemcells) + X <- stemcells$gene[, 1:10] + Y <- stemcells$gene[, 1:10] + s <- stemcells$study + + res.mint.spls <- mint.spls(X, Y, study=s, keepX = c(3,3), keepY = c(3,3)) + + mint.spls.cim <- cim(res.mint.spls) + + invisible(capture.output(TT <- dput(mint.spls.cim[testable.components]))) + + expect_equal(TT, GT) }) -test_that("CIM works for spls with X mapping", code = { + +test_that("(cim:basic): mint.splsda", { + + testable.components <- Testable.Components$basic.mint.splsda + GT <- Ground.Truths$basic.mint.splsda + + set.seed(17) + samples <- sample(1:125, 40) + + data(stemcells) + X <- stemcells$gene[samples, 1:10] + Y <- stemcells$celltype[samples] + s <- c(rep(1,10), rep(2,10), rep(3,10), rep(4,10)) + + res.mint.splsda <- mint.splsda(X, Y, study=s, keepX = c(3,3)) + + mint.splsda.cim <- cim(res.mint.splsda) + + invisible(capture.output(TT <- dput(mint.splsda.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(cim:data): multidrug", { + + testable.components <- Testable.Components$multidrug.spca + GT <- Ground.Truths$multidrug.spca + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.multidrug <- spca(X, keepX = c(3,3)) + + multidrug.cim <- cim(res.multidrug) + + invisible(capture.output(TT <- dput(multidrug.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================= PARAMETER =============================== ### +############################################################################### + + +test_that("(cim:paramter): cutoff", { + + testable.components <- Testable.Components$cutoff.spls + GT <- Ground.Truths$cutoff.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + cutoff.cim <- cim(res.spls, cutoff = 0.2) + + invisible(capture.output(TT <- dput(cutoff.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:paramter): cut.tree", { + + testable.components <- Testable.Components$cut.tree.spls + GT <- Ground.Truths$cut.tree.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + cut.tree.cim <- cim(res.spls, cut.tree = c(0.5, 0.5)) + + invisible(capture.output(TT <- dput(cut.tree.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:paramter): cluster", { + + testable.components <- Testable.Components$cluster.spls + GT.none <- Ground.Truths$cluster.none.spls + GT.row <- Ground.Truths$cluster.row.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + cluster.none.cim <- cim(res.spls, cluster = "none") + cluster.row.cim <- cim(res.spls, cluster = "row") + + invisible(capture.output(TT <- dput(cluster.none.cim[testable.components]))) + expect_equal(TT, GT.none) + + invisible(capture.output(TT <- dput(cluster.row.cim[testable.components]))) + expect_equal(TT, GT.row) +}) + + +test_that("(cim:paramter): dist.method", { + + testable.components <- Testable.Components$dist.method.spls + GT.correlation <- Ground.Truths$dist.correlation.spls + GT.manhattan <- Ground.Truths$dist.manhattan.spls + data(liver.toxicity) - X <- liver.toxicity$gene - Y <- liver.toxicity$clinic - liver.spls <- spls(X, Y, ncomp = 3, - keepX = c(2, 5, 5), keepY = c(10, 10, 10)) - cim_res <- cim(liver.spls, mapping = "X") - expect_is(cim_res[[1]], "matrix") + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + dist.correlation.cim <- cim(res.spls, dist.method = c("correlation", "correlation"), + cluster = "row") + dist.manhattan.cim <- cim(res.spls, dist.method = c("manhattan", "manhattan"), + cluster = "row") + + invisible(capture.output(TT <- dput(dist.correlation.cim[testable.components]))) + expect_equal(TT, GT.correlation) + + invisible(capture.output(TT <- dput(dist.manhattan.cim[testable.components]))) + expect_equal(TT, GT.manhattan) }) -test_that("CIM works for multilevel", code = { + +test_that("(cim:paramter): clust.method", { + + testable.components <- Testable.Components$clust.method.spls + GT.centroid <- Ground.Truths$clust.centroid.spls + GT.complete <- Ground.Truths$clust.complete.spls + data(liver.toxicity) - repeat.indiv <- c(1, 2, 1, 2, 1, 2, 1, 2, 3, 3, 4, 3, 4, 3, 4, 4, 5, 6, 5, 5, - 6, 5, 6, 7, 7, 8, 6, 7, 8, 7, 8, 8, 9, 10, 9, 10, 11, 9, 9, - 10, 11, 12, 12, 10, 11, 12, 11, 12, 13, 14, 13, 14, 13, 14, - 13, 14, 15, 16, 15, 16, 15, 16, 15, 16) - design <- data.frame(sample = repeat.indiv) - res.spls.1level <- spls(X = liver.toxicity$gene, - Y=liver.toxicity$clinic, - multilevel = design, - ncomp = 2, - keepX = c(50, 50), keepY = c(5, 5), - mode = 'canonical') - - stim.col <- c("darkblue", "purple", "green4","red3") - cim_res <- cim(res.spls.1level, mapping="Y", - row.sideColors = stim.col[factor(liver.toxicity$treatment[,3])], comp = 1, - legend=list(legend = unique(liver.toxicity$treatment[,3]), col=stim.col, - title = "Dose", cex=0.9)) - expect_is(cim_res[[1]], "matrix") -}) - -unlink(list.files(pattern = "*.pdf")) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + clust.centroid.cim <- cim(res.spls, clust.method = c("centroid", "centroid"), + cluster = "row") + clust.complete.cim <- cim(res.spls, clust.method = c("complete", "complete"), + cluster = "row") + + invisible(capture.output(TT <- dput(clust.centroid.cim[testable.components]))) + expect_equal(TT, GT.centroid) + + invisible(capture.output(TT <- dput(clust.complete.cim[testable.components]))) + expect_equal(TT, GT.complete) +}) + + +test_that("(cim:paramter): comp",{ + + testable.components <- Testable.Components$comp.spls + GT <- Ground.Truths$comp.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3), ncomp = 4) + + comp.cim <- cim(res.spls, comp = c(2,3)) + + invisible(capture.output(TT <- dput(comp.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(cim:paramter): mapping",{ + + testable.components <- Testable.Components$mapping.spls + GT <- Ground.Truths$mapping.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10,1:10] + Y <- liver.toxicity$clinic[1:10,1:10] + + res.spls <- spls(X, Y, keepX = c(3,3), keepY = c(3,3)) + + mapping.cim <- cim(res.spls, mapping = "X") + + invisible(capture.output(TT <- dput(mapping.cim[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(cim:error): cluster is valid value", { + + data(nutrimouse) + X <- nutrimouse$lipid + + res.spca <- spca(X) + + expect_error(cim(res.spca, cluster = "invalid.cluster"), + "'cluster' should be one of 'both', 'row', 'column' or 'none'.", + fixed=TRUE) +}) + + +test_that("(cim:error): clust.method is valid value", { + + data(nutrimouse) + X <- nutrimouse$lipid + + res.spca <- spca(X) + + expect_error(cim(res.spca, clust.method = c("ward", "invalid.cluster")), + "invalid clustering method.", + fixed=TRUE) +}) + + +test_that("(cim:error): dist.method is valid value", { + + data(nutrimouse) + X <- nutrimouse$lipid + + res.spca <- spca(X) + + expect_error(cim(res.spca, dist.method = c("euclidean", "invalid.cluster")), + "invalid distance method.", + fixed=TRUE) +}) + + +test_that("(cim:error): cut.tree is valid value", { + + data(nutrimouse) + X <- nutrimouse$lipid + + res.spca <- spca(X) + + expect_error(cim(res.spca, cut.tree=0.8), + "'cut.tree' must be a numeric vector of length 2.", + fixed=TRUE) + + expect_error(cim(res.spca, cut.tree=c(2,2)), + "Components of 'cut.tree' must be between 0 and 1.", + fixed=TRUE) +}) + + +test_that("(cim:error): doesn't allow block.splsda objects", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + res.block.splsda <- block.splsda(X, Y) + + expect_error(cim(res.block.splsda), + "Please call the 'cimDiablo' function on your 'block.splsda' object", + fixed=TRUE) +}) \ No newline at end of file diff --git a/tests/testthat/test-circosPlot.R b/tests/testthat/test-circosPlot.R new file mode 100644 index 00000000..4070e906 --- /dev/null +++ b/tests/testthat/test-circosPlot.R @@ -0,0 +1,243 @@ +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# parameter - no parameter type tests as all only affect visualisation + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-circosPlot.rda", package = "mixOmics")) +Ground.Truths <- Test.Data$gt + + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(circosPlot:basic): block.spls", { + + GT <- Ground.Truths$basic.block.spls + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10]) + Y <- breast.TCGA$data.train$protein[, 1:5] + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.block.spls <- block.spls(X, Y, + keepX = choice.keepX) + + block.spls.circos <- circosPlot(res.block.spls, group = breast.TCGA$data.train$subtype, + cutoff=0.0) + + invisible(capture.output(TT <- dput(block.spls.circos))) + + expect_equal(TT, GT) +}) + + +test_that("(circosPlot:basic): block.splsda", { + + GT <- Ground.Truths$basic.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10]) + Y <- breast.TCGA$data.train$subtype + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.block.splsda <- block.splsda(X, Y, + keepX = choice.keepX) + + block.splsda.circos <- circosPlot(res.block.splsda, + cutoff=0.0) + + invisible(capture.output(TT <- dput(block.splsda.circos))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(circosPlot:data): nutrimouse", { + + GT <- Ground.Truths$nutrimouse.block.splsda + + data(nutrimouse) + Y = nutrimouse$diet + X = list(gene = nutrimouse$gene[, 1:10], + lipid = nutrimouse$lipid[, 1:10]) + + choice.keepX <- list(gene = c(3,3), + lipid = c(3,3)) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + nutrimouse.circos <- circosPlot(res.block.splsda, cutoff = 0.0) + + invisible(capture.output(TT <- dput(nutrimouse.circos))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(circosPlot:error): group parameter has appropriate value", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna) + + choice.keepX <- list(miRNA = c(10, 10), + mRNA = c(10, 10)) + + res.block.spls <- block.spls(X, Y <- breast.TCGA$data.train$protein, + keepX = choice.keepX) + + err <- "group must be a factor of length: nrow(object$X$Y) = 150\n" + + expect_error(circosPlot(res.block.spls, group = breast.TCGA$data.test$subtype, + cutoff=0.7), + err, + fixed = T) + + expect_error(circosPlot(res.block.spls, cutoff=0.7), + err, + fixed = T) +}) + + +test_that("(circosPlot:error): ensure there is minimum of three blocks", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna) + + choice.keepX <- list(miRNA = c(10, 10)) + + res.block.splsda <- block.splsda(X, Y = breast.TCGA$data.train$subtype, + keepX = choice.keepX) + + expect_error(circosPlot(res.block.splsda, + cutoff=0.7), + "This function is only available when there are more than 3 blocks + (2 in object$X + an outcome object$Y)", + fixed=T) +}) + + +test_that("(circosPlot:error): ensure cutoff parameter is specified", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna) + + choice.keepX <- list(miRNA = c(10, 10), + mRNA = c(10, 10)) + + res.block.splsda <- block.splsda(X, Y = breast.TCGA$data.train$subtype, + keepX = choice.keepX) + + expect_error(circosPlot(res.block.splsda), + "'cutoff' is missing", + fixed = T) + +}) + + +test_that("(circosPlot:error): cannot take block.pls objects", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna) + + res.block.pls <- block.pls(X, Y = breast.TCGA$data.train$protein) + + expect_error(circosPlot(res.block.pls, group = breast.TCGA$data.train$subtype, + cutoff=0.7), + "no applicable method for 'circosPlot' applied to an object of class \"c('block.pls', 'sgcca')\"", + fixed = T) +}) + + +test_that("(circosPlot:error): cannot take block.plsda objects", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna) + + res.block.plsda <- block.plsda(X, Y = breast.TCGA$data.train$subtype) + + expect_error(circosPlot(res.block.plsda, cutoff=0.7), + "no applicable method for 'circosPlot' applied to an object of class \"c('block.plsda', 'block.pls', 'sgccda', 'sgcca', 'DA')\"", + fixed=T) +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(circosPlot:warning): works with similar feature names in different blocks", { + + create_similar_feature_names <- function(data_list) + { + lapply(data_list, function(x){ + colnames(x) <- paste0('feature_', seq_len(ncol(x))) + x + }) + } + + data("breast.TCGA") + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + + X <- create_similar_feature_names(X) + + choice.keepX <- list(miRNA = c(10, 10), + mRNA = c(10, 10), + proteomics = c(10,10)) + + res.block.splsda = block.splsda(X = X, Y = breast.TCGA$data.train$subtype, + keepX = choice.keepX) + + expect_output(circosPlot(res.block.splsda, cutoff = 0.7), + "adding block name to feature names in the output similarity matrix as there are similar feature names across blocks.", + fixed=T) +}) + + +test_that("(circosPlot:warning): warning for high cutoff value", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna) + + choice.keepX <- list(miRNA = c(10, 10), + mRNA = c(10, 10)) + + res.block.splsda <- block.splsda(X, Y = breast.TCGA$data.train$subtype, + keepX = choice.keepX) + + expect_warning(circosPlot(res.block.splsda, cutoff=0.99), + "Choose a lower correlation threshold to highlight + links between datasets", + fixed=T) +}) + diff --git a/tests/testthat/test-circsPlot.R b/tests/testthat/test-circsPlot.R deleted file mode 100644 index 06a8f29e..00000000 --- a/tests/testthat/test-circsPlot.R +++ /dev/null @@ -1,59 +0,0 @@ -test_that("circosPlot works", code = { - data(nutrimouse) - Y = nutrimouse$diet - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) - - - nutrimouse.sgccda <- wrapper.sgccda(X=data, - Y = Y, - design = design, - keepX = list(gene=c(8,8), lipid=c(4,4)), - ncomp = 2, - scheme = "horst") - - - cp_res <- circosPlot(nutrimouse.sgccda, cutoff = 0.7, ncol.legend = 2, size.legend = 1.1, - color.Y = 1:5, color.blocks = c("green","brown"), color.cor = c("magenta", "purple")) - expect_is(cp_res, "matrix") - -}) - -test_that("circosPlot works with similar feature names in different blocks", code = { - - create_similar_feature_names <- function(data_list) - { - lapply(data_list, function(x){ - colnames(x) <- paste0('feature_', seq_len(ncol(x))) - x - }) - } - data("breast.TCGA") - data = list(mrna = breast.TCGA$data.train$mrna, - mirna = breast.TCGA$data.train$mirna, - protein = breast.TCGA$data.train$protein) - - data <- create_similar_feature_names(data) - list.keepX = list(mrna = rep(20, 2), mirna = rep(10,2), protein = rep(10, 2)) - TCGA.block.splsda = block.splsda(X = data, Y = breast.TCGA$data.train$subtype, - ncomp = 2, keepX = list.keepX, design = 'full') - cp_res <- circosPlot(TCGA.block.splsda, cutoff = 0.7) - - expect_is(cp_res, "matrix") -}) - -test_that("circosPlot works when using the indY parameter", code = { - - data("breast.TCGA") - data = list(mrna = breast.TCGA$data.train$mrna, - mirna = breast.TCGA$data.train$mirna, - protein = breast.TCGA$data.train$protein) - - list.keepX = list(mrna = rep(20, 2), mirna = rep(10,2), protein = rep(10, 2)) - TCGA.block.spls = block.spls(X = data, indY = 3, - ncomp = 2, keepX = list.keepX, design = 'full') - cp_res <- circosPlot(TCGA.block.spls, cutoff = 0.7, group = breast.TCGA$data.train$subtype) - - expect_is(cp_res, "matrix") -}) - diff --git a/tests/testthat/test-diablo.R b/tests/testthat/test-diablo.R new file mode 100644 index 00000000..0dce87f6 --- /dev/null +++ b/tests/testthat/test-diablo.R @@ -0,0 +1,414 @@ + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-diablo.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(diablo:basic): block.splsda", { + + testable.components <- Testable.Components$basic.block.splsda + GT <- Ground.Truths$basic.block.splsda + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + invisible(capture.output(TT <- dput(res.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(diablo:basic): wrapper.sgccda", { + + testable.components <- Testable.Components$basic.wrapper.sgccda + GT <- Ground.Truths$basic.wrapper.sgccda + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.sgccda <- wrapper.sgccda(X, Y, keepX = choice.keepX) + + invisible(capture.output(TT <- dput(res.sgccda[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(diablo:data): breast.test", { + + testable.components <- Testable.Components$breast.test.block.splsda + GT <- Ground.Truths$breast.test.block.splsda + + set.seed(16) + samples <- sample(1:70, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.test$mirna[samples,1:10], + mRNA = breast.TCGA$data.test$mrna[samples,1:10]) + Y = breast.TCGA$data.test$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3)) + + breast.test.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + invisible(capture.output(TT <- dput(breast.test.res.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(diablo:parameter): indY", { + + testable.components <- Testable.Components$indY.block.splsda + GT <- Ground.Truths$indY.block.splsda + + set.seed(16) + samples <- sample(1:70, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + subtype = breast.TCGA$data.train$subtype[samples]) + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.indY.block.splsda <- block.splsda(X, indY=3, keepX = choice.keepX) + + invisible(capture.output(TT <- dput(res.indY.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(diablo:parameter): ncomp", { + + testable.components <- Testable.Components$ncomp.block.splsda + GT <- Ground.Truths$ncomp.block.splsda + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + ncomp.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + ncomp = 3) + + invisible(capture.output(TT <- dput(ncomp.res.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(diablo:parameter): design", { + + testable.components <- Testable.Components$design.block.splsda + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + design.0.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + design = 0) + design.null.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + design = "null") + + design.0.5.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + design = 0.5) + + design.1.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + design = 1) + design.full.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + design = "full") + + invisible(capture.output(TT <- dput(design.0.res.block.splsda[testable.components]))) + GT <- Ground.Truths$design.0.block.splsda + expect_equal(TT, GT) + invisible(capture.output(expect_equal(TT, dput(design.null.res.block.splsda[testable.components])))) + + invisible(capture.output(TT <- dput(design.0.5.res.block.splsda[testable.components]))) + GT <- Ground.Truths$design.0.5.block.splsda + expect_equal(TT, GT) + + invisible(capture.output(TT <- dput(design.1.res.block.splsda[testable.components]))) + GT <- Ground.Truths$design.1.block.splsda + expect_equal(TT, GT) + invisible(capture.output(expect_equal(TT, dput(design.full.res.block.splsda[testable.components])))) +}) + + +test_that("(diablo:parameter): scheme", { + + testable.components <- Testable.Components$scheme.block.splsda + GT <- Ground.Truths$scheme.block.splsda + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + scheme.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + scheme = "factorial") + + invisible(capture.output(TT <- dput(scheme.res.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(diablo:parameter): near.zero.var", { + + testable.components <- Testable.Components$nzv.block.splsda + GT <- Ground.Truths$nzv.block.splsda + + create.many.zeroes <- function(x) { + for (i in 1:length(x)) { + set.seed(16) + x[[i]][, 1:7] <- 0 + } + return(x) + } + + set.seed(16) + samples <- sample(1:150, 10) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3)) + + X <- create.many.zeroes(X) + + nzv.res.block.splsda <- suppressWarnings(block.splsda(X, Y, keepX = choice.keepX, + near.zero.var = T)) + + invisible(capture.output(TT <- dput(nzv.res.block.splsda[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(diablo:parameter): all.outputs", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna, + mRNA = breast.TCGA$data.train$mrna, + proteomics = breast.TCGA$data.train$protein) + Y = breast.TCGA$data.train$subtype + + choice.keepX = list(miRNA = c(10,10), + mRNA = c(10,10), + proteomics = c(10,10)) + + all.outputs.res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX, + all.outputs = F) + + expect_equal(all.outputs.res.block.splsda$AVE, NULL) + expect_equal(all.outputs.res.block.splsda$prop_expl_var, NULL) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(diablo:error): ensure row names are the same", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples[c(5,4,3,2,1)],1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + expect_error(block.splsda(X, Y, keepX = choice.keepX), + "Please check the rownames of the data, there seems to be some + discrepancies", + fixed=T) +}) + + +test_that("(diablo:error): ensure Y is a class vector/factor", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$mrna[samples, ] + + expect_error(block.splsda(X, Y), + "'Y' should be a factor or a class vector.", + fixed=T) +}) + + +test_that("(diablo:error): ensure each block has unique name", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + miRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + expect_error(block.splsda(X, Y), + "Each block of 'X' must have a unique name.", + fixed=T) +}) + + +test_that("(diablo:error): ensure each block has same number of rows", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples[c(1,2,3)],1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + expect_error(block.splsda(X, Y), + "Unequal number of rows among the blocks of 'X'", + fixed=T) +}) + + +test_that("(diablo:error): ensure design is in the right format", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + d <- matrix(c(0,1,1,0), nrow = 2) + + expect_error(block.splsda(X, Y, design=d), + "'design' must be a square matrix with 3columns.", + fixed=T) +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(diablo:error): notify user of ignoring indY", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + expect_warning(block.splsda(X, Y, indY=3), + "'Y' and 'indY' are provided, 'Y' is used.", + fixed=T) +}) + + +test_that("(diablo:error): notify user of automatic lowering of ncomp", { + + set.seed(16) + samples <- sample(1:150, 5) + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + expect_warning(block.splsda(X, Y, ncomp = 11), + "Reset maximum number of variates 'ncomp[1]' + to ncol(X[[1]])= 10.", + fixed=T) +}) diff --git a/tests/testthat/test-diabolo.R b/tests/testthat/test-diabolo.R deleted file mode 100644 index 1f660a59..00000000 --- a/tests/testthat/test-diabolo.R +++ /dev/null @@ -1,85 +0,0 @@ -context("diabolo") - -test_that("block.splsda works", { - data(nutrimouse) - Y = nutrimouse$diet - - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE, - dimnames = list(c("gene", "lipid", "Y"), - c("gene", "lipid", "Y"))) - - - nutrimouse.sgccda <- block.splsda(X = data, - Y = Y, - design = design, - keepX = list(gene = c(10,10), - lipid = c(15,15)), - ncomp = 2, - scheme = "centroid", - tol = 1e-30) - expect_length(nutrimouse.sgccda, 24L) - - expect_equal(names(nutrimouse.sgccda), - c("call", "X", "Y", "ind.mat", "ncomp", "mode", "keepX", "keepY", - "variates", "loadings", "crit", "AVE", "names", "init", "tol", - "iter", "max.iter", "nzv", "scale", "design", "scheme", "indY", - "weights", "prop_expl_var")) - - expect_is(nutrimouse.sgccda$X, "list") - expect_is(nutrimouse.sgccda$design, "matrix") - expect_is(nutrimouse.sgccda$X$gene, "matrix") - expect_is(nutrimouse.sgccda$X$lipid, "matrix") - - expect_equal(nutrimouse.sgccda$design, design) - expect_equal(dim(nutrimouse.sgccda$X$gene), dim(data$gene)) - expect_equal(dim(nutrimouse.sgccda$X$lipid), dim(data$lipid)) - expect_equal(nutrimouse.sgccda$X$gene[1, 1], 0.524732755905559) - expect_equal(nutrimouse.sgccda$X$lipid[1, 1], -0.528375020663953) - expect_is(nutrimouse.sgccda$ind.mat, "matrix") - - expect_equal(dim(nutrimouse.sgccda$ind.mat), c(40L, 5L)) - - expect_equal(nutrimouse.sgccda$Y, Y) - - expect_equal(nutrimouse.sgccda$ncomp, c("gene" = 2L, "lipid" = 2L, "Y" = 2L)) - - expect_equal(nutrimouse.sgccda$mode, "regression") - - expect_equal(dim(nutrimouse.sgccda$loadings$gene), c(120L, 2L)) - expect_equal(dim(nutrimouse.sgccda$loadings$lipid), c(21L, 2L)) - expect_equal(dim(nutrimouse.sgccda$loadings$Y), c(5L, 2L)) - - expect_null(nutrimouse.sgccda$nzv) - - expect_true(nutrimouse.sgccda$scale) - - expect_equal(nutrimouse.sgccda$scheme, "centroid") - expect_equal(nutrimouse.sgccda$scheme, "centroid") - - expect_equal(nutrimouse.sgccda$indY, 3L) - - expect_equal(rowMeans(nutrimouse.sgccda$weights), - c(gene = 0.694506104274723, lipid = 0.915845972615744)) - - expect_length(nutrimouse.sgccda$prop_expl_var, 3L) - expect_is(nutrimouse.sgccda$prop_expl_var, "list") - expect_equal(names(nutrimouse.sgccda$prop_expl_var), colnames(design)) - - expect_length(nutrimouse.sgccda$AVE, 3L) - expect_equal(names(nutrimouse.sgccda$AVE), - c("AVE_X", "AVE_outer", "AVE_inner")) - expect_equal(nutrimouse.sgccda$AVE$AVE_outer[1], 0.217938372815004) - expect_equal(nutrimouse.sgccda$AVE$AVE_inner[1], 0.663209598406049) - expect_equal(nutrimouse.sgccda$AVE$AVE_X$Y[1], c(`comp1` = 0.25)) - - expect_length(nutrimouse.sgccda$variates, 3L) - expect_equal(names(nutrimouse.sgccda$variates), c("gene", "lipid", "Y")) - expect_is(nutrimouse.sgccda$variates$gene, "matrix") - expect_is(nutrimouse.sgccda$variates$lipid, "matrix") - expect_is(nutrimouse.sgccda$variates$Y, "matrix") - - expect_equal(nutrimouse.sgccda$variates$gene[1, 1], 2.9424296984024) - expect_equal(nutrimouse.sgccda$variates$lipid[1, 1], 2.73351593820324) - expect_equal(nutrimouse.sgccda$variates$Y[1, 1], 0.639567998302767) -}) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 725fd06b..30c6c55e 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -1,41 +1,381 @@ -context("network") -test_that("network works for rcc", { +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-network.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(basic:network): matrix", { + + testable.components <- Testable.Components$basic.matrix + GT <- Ground.Truths$basic.matrix + + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + res.cor <- cor(X, Y) + + matrix.network <- network(res.cor) + + invisible(capture.output(TT <- dput(matrix.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): pls", { + + testable.components <- Testable.Components$basic.pls + GT <- Ground.Truths$basic.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + res.pls <- pls(X, Y) - ## network representation for objects of class 'rcc' + pls.network <- network(res.pls) + + invisible(capture.output(TT <- dput(pls.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): spls", { + + testable.components <- Testable.Components$basic.spls + GT <- Ground.Truths$basic.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + choice.keepX <- c(3,3) + choice.keepY <- c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX, keepY = choice.keepY) + + spls.network <- network(res.spls) + + invisible(capture.output(TT <- dput(spls.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + data(srbct) + X <- srbct$gene[, 1:10] + Y <- srbct$class + + res.plsda <- plsda(X, Y) + + plsda.network <- network(res.plsda) + + invisible(capture.output(TT <- dput(plsda.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + data(srbct) + X <- srbct$gene[, 1:10] + Y <- srbct$class + + choice.keepX <- c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + splsda.network <- network(res.splsda) + + invisible(capture.output(TT <- dput(splsda.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): rcc", { + + testable.components <- Testable.Components$basic.rcc + GT <- Ground.Truths$basic.rcc + data(nutrimouse) - X <- nutrimouse$lipid - Y <- nutrimouse$gene - nutri.res <- rcc(X, Y, ncomp = 3, lambda1 = 0.064, lambda2 = 0.008) + X <- nutrimouse$lipid[, 1:10] + Y <- nutrimouse$gene[, 1:10] + + res.rcc <- rcc(X, Y, method = "shrinkage") + + rcc.network <- network(res.rcc) + + invisible(capture.output(TT <- dput(rcc.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): sgcca", { + + testable.components <- Testable.Components$basic.sgcca + GT <- Ground.Truths$basic.sgcca + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.sgcca <- wrapper.sgcca(X, keepX = choice.keepX, ncomp = 3) + + sgcca.network <- network(res.sgcca) + + invisible(capture.output(TT <- dput(sgcca.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): block.spls", { + + testable.components <- Testable.Components$basic.block.spls + GT <- Ground.Truths$basic.block.spls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.spls <- block.spls(X, indY=3, keepX = choice.keepX, ncomp = 3) + + block.spls.network <- network(res.block.spls) + + invisible(capture.output(TT <- dput(block.spls.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): sgccda", { + + testable.components <- Testable.Components$basic.sgccda + GT <- Ground.Truths$basic.sgccda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.sgccda <- wrapper.sgccda(X, Y, keepX = choice.keepX) + + sgccda.network <- network(res.sgccda) + + invisible(capture.output(TT <- dput(sgccda.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(basic:network): block.splsda", { + + testable.components <- Testable.Components$basic.sgccda + GT <- Ground.Truths$basic.sgccda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + block.splsda.network <- network(res.block.splsda) + + invisible(capture.output(TT <- dput(block.splsda.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(parameter:network): cutoff", { + + testable.components <- Testable.Components$cutoff.pls + GT <- Ground.Truths$cutoff.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + res.pls <- pls(X, Y) + + cutoff.network <- network(res.pls, cutoff = 0.4) + + invisible(capture.output(TT <- dput(cutoff.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(parameter:network): blocks", { + + testable.components <- Testable.Components$blocks.block.spls + GT <- Ground.Truths$blocks.block.spls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.spls <- block.spls(X, indY=3, keepX = choice.keepX, ncomp = 3) + + blocks.network <- network(res.block.spls, blocks = c(1,3)) + + invisible(capture.output(TT <- dput(blocks.network[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(error:network): catches unaccepted file extensions", { - ## create a tmp file - tmp.file <- tempfile("network", fileext = ".jpeg") - network.rcc.res <- network(nutri.res, comp = 1:3, cutoff = 0.6, save = "jpeg", - name.save = tmp.file) - expect_equal(names(network.rcc.res), c("gR", "M", "cutoff")) - .expect_numerically_close(sum(network.rcc.res$M), 10.8786, digits = 3) - unlink(tmp.file) + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + choice.keepX <- c(3,3) + choice.keepY <- c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX, keepY = choice.keepY) + + expect_error(network(res.spls, name.save = "network", save = "raw"), + "'save' must be one of 'jpeg', 'png', 'tiff' or 'pdf'.", + fixed = T) +}) + + +test_that("(error:network): catches unaccepted input objects", { + + data(stemcells) + X <- stemcells$gene + + res.pca <- pca(X) + + expect_error(network(res.pca), + "'network' is only implemented for the following objects: matrix, pls, plsda, spls, splsda, rcc, sgcca, rgcca, sgccda", + fixed = T) }) -test_that("network works for spls", { + +test_that("(error:network): catches unaccepted row.names/col.names values", { + data(liver.toxicity) - X <- liver.toxicity$gene - Y <- liver.toxicity$clinic - toxicity.spls <- spls(X, Y, ncomp = 3, keepX = c(50, 50, 50), - keepY = c(10, 10, 10)) - ## create a tmp file - tmp.file <- tempfile("network", fileext = ".jpeg") - network.spls.res <- network(toxicity.spls, comp = 1:3, cutoff = 0.8, - color.node = c("mistyrose", "lightcyan"), - shape.node = c("rectangle", "circle"), - color.edge = color.spectral(100), - lty.edge = "solid", lwd.edge = 1, - show.edge.labels = FALSE, interactive = FALSE, save = "jpeg", - name.save = tmp.file) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + choice.keepX <- c(3,3) + choice.keepY <- c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX, keepY = choice.keepY) + + expect_error(network(res.spls, row.names = "random.name"), + "'row.names' must be a character vector of 10 unique entries.", + fixed = T) + + expect_error(network(res.spls, col.names = "random.name"), + "'col.names' must be a character vector of 10 unique entries.", + fixed = T) +}) + + +test_that("(error:network): catches unaccepted blocks values", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[, 1:10], + mRNA = breast.TCGA$data.train$mrna[, 1:10], + proteomics = breast.TCGA$data.train$protein[, 1:10]) + + choice.keepX <- list(miRNA = 3, + mRNA = 3, + proteomics = 3) + + res.block.spls <- block.spls(X, ncomp=1, indY=3, keepX = choice.keepX) + + expect_error(network(res.block.spls, blocks = c("random.block", "random.block")), + "One element of 'blocks' does not match with the names of the blocks", + fixed = T) - expect_equal(names(network.spls.res), c("gR", "M", "cutoff")) - .expect_numerically_close(sum(network.spls.res$M), 45.6061, digits = 3) - unlink(tmp.file) + expect_error(network(res.block.spls, blocks = c(3,4)), + "Incorrect value for 'blocks", + fixed = T) + +}) + + +test_that("(error:network): catches cutoff values which are too high", { + + data(liver.toxicity) + X <- liver.toxicity$gene[, 1:10] + Y <- liver.toxicity$clinic[, 1:10] + + res.spls <- spls(X, Y) + + expect_error(network(res.spls, cutoff = 0.99), + "You have chosen a high cutoff value of 0.99 which is greaer than the max value in the similarity matrix which is 0.43", + fixed=T) }) + + +dev.off() unlink(list.files(pattern = "*.pdf")) diff --git a/tests/testthat/test-pca.R b/tests/testthat/test-pca.R index 9d2b8d54..a07f245b 100644 --- a/tests/testthat/test-pca.R +++ b/tests/testthat/test-pca.R @@ -1,7 +1,259 @@ -context('pca') +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### -test_that("pca works as expected", code = { - data(multidrug) - pca.res1 <- pca(multidrug$ABC.trans, ncomp = 2, scale = TRUE) - expect_is(pca.res1, 'pca') + + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-pca.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(pca:basic): multidrug", { + + testable.components <- Testable.Components$basic.pca + GT <- Ground.Truths$basic.pca + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) + +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(pca:data): srbct", { + + testable.components <- Testable.Components$srbct.pca + GT <- Ground.Truths$srbct.pca + + data(srbct) + X <- srbct$gene[1:10, 1:10] + + res.pca <- pca(X) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) + +}) + + +test_that("(pca:data): liver.toxicity", { + + testable.components <- Testable.Components$liver.toxicity.pca + GT <- Ground.Truths$liver.toxicity.pca + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10, 1:10] + + res.pca <- pca(X) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) + +}) + + +test_that("(pca:data): nutrimouse", { + + testable.components <- Testable.Components$nutrimouse.pca + GT <- Ground.Truths$nutrimouse.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + res.pca <- pca(X) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) + +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(pca:parameter): ncomp", { + + testable.components <- Testable.Components$ncomp.pca + GT <- Ground.Truths$ncomp.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + res.pca <- pca(X, ncomp = 3) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(pca:parameter): center", { + + testable.components <- Testable.Components$center.pca + GT <- Ground.Truths$center.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + res.pca <- pca(X, center = F) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(pca:parameter): scale", { + + testable.components <- Testable.Components$scale.pca + GT <- Ground.Truths$scale.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + res.pca <- pca(X, scale = T) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(pca:parameter): logratio", { + + testable.components <- Testable.Components$logratio.pca + GT <- Ground.Truths$logratio.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + X <- X + 0.01 + res.pca <- pca(X, logratio = "CLR") + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(pca:parameter): ilr.offset", { + + testable.components <- Testable.Components$ilr.offset.pca + GT <- Ground.Truths$ilr.offset.pca + + data(nutrimouse) + X <- nutrimouse$lipid[1:10, 1:10] + + res.pca <- pca(X, ilr.offset = 0.5) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(pca:parameter): multilevel", { + + testable.components <- Testable.Components$multilevel.pca + GT <- Ground.Truths$multilevel.pca + + data(vac18) + X <- vac18$genes[1:10, 1:10] + ml <- c(rep(1,2), rep(2,2), rep(3,2), rep(4,2), rep(5,2)) + + res.pca <- pca(X, multilevel = ml) + + invisible(capture.output(TT <- dput(res.pca[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(pca:error): catches all invalid values of ncomp", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + expect_error(pca(X, ncomp = "number"), + "`ncomp` must be numeric", + fixed=T) + + expect_error(pca(X, ncomp = -1), + "invalid value for 'ncomp'.", + fixed=T) + + expect_error(pca(X, ncomp = 20), + "use smaller 'ncomp'", + fixed=T) +}) + + +test_that("(pca:error): catches all invalid values of center", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + expect_error(pca(X, center = "number"), + "'center' should be either a logical value or a numeric vector of length equal to the number of columns of 'X'.", + fixed=T) + + expect_error(pca(X, center = c(2,3,4)), + "'center' should be either a logical value or a numeric vector of length equal to the number of columns of 'X'.", + fixed=T) +}) + + +test_that("(pca:error): catches all invalid values of scale", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + expect_error(pca(X, scale = "number"), + "'scale' should be either a logical value or a numeric vector of length equal to the number of columns of 'X'.", + fixed=T) + + expect_error(pca(X, scale = c(2,3,4)), + "'scale' should be either a logical value or a numeric vector of length equal to the number of columns of 'X'.", + fixed=T) +}) + + +test_that("(pca:error): catches when multilevel has differing length to nrow(X)", { + + data(vac18) + X <- vac18$genes[1:9, 1:10] # nrow(X) = 9 + ml <- c(rep(1,2), rep(2,2), rep(3,2), rep(4,2), rep(5,2)) # length(ml) = 10 + + expect_error(pca(X, multilevel = ml), + "unequal number of rows in 'X' and 'multilevel'.", + fixed=T) }) diff --git a/tests/testthat/test-perf.diablo.R b/tests/testthat/test-perf.diablo.R index 769a1949..d808aedc 100644 --- a/tests/testthat/test-perf.diablo.R +++ b/tests/testthat/test-perf.diablo.R @@ -1,46 +1,369 @@ -context("perf.diablo") -test_that("perf.diablo works ", { - data(nutrimouse) - Y = nutrimouse$diet - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) - nutrimouse.sgccda <- block.splsda(X=data, Y = Y,design = design, keepX = list(gene=c(10,10), lipid=c(15,15)), ncomp = 2, scheme = "horst") - perf = perf(nutrimouse.sgccda, folds = 3, nrepeat = 2) - expect_is(perf, "perf.sgccda.mthd") +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# edge cases +## At least one class is not represented in one fold, which may unbalance the error rate.\n Consider a number of folds lower than the minimum in table(Y): + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-perf.diablo.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(perf.diablo:basic): block.plsda", { + + testable.components <- Testable.Components$basic.block.plsda + GT <- Ground.Truths$basic.block.plsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + res.block.plsda <- block.plsda(X, Y) + + set.seed(100) + block.plsda.perf = perf(res.block.plsda, folds=3) + + invisible(capture.output(TT <- dput(block.plsda.perf[testable.components]))) + + expect_equal(TT, GT) }) -test_that("perf.diablo works with and without parallel processing and with auroc", { +test_that("(perf.diablo:basic): block.splsda", { + + testable.components <- Testable.Components$basic.block.splsda + GT <- Ground.Truths$basic.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=3) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:basic): sgccda", { + + testable.components <- Testable.Components$basic.block.splsda + GT <- Ground.Truths$basic.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.sgccda <- wrapper.sgccda(X, Y, keepX = keepX) + + set.seed(100) + sgccda.perf = perf(res.sgccda, folds=3) + + invisible(capture.output(TT <- dput(sgccda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(perf.diablo:data): breast.tcga test", { + + testable.components <- Testable.Components$breast.test.block.splsda + GT <- Ground.Truths$breast.test.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 22:26, 35:39) + X = list(miRNA = breast.TCGA$data.test$mirna[samples, 1:10], + mRNA = breast.TCGA$data.test$mrna[samples, 1:10]) + Y = breast.TCGA$data.test$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=3) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:data): block.splsda", { + + testable.components <- Testable.Components$breast.test.block.splsda + GT <- Ground.Truths$breast.test.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 22:26, 35:39) + X = list(miRNA = breast.TCGA$data.test$mirna[samples, 1:10], + mRNA = breast.TCGA$data.test$mrna[samples, 1:10]) + Y = breast.TCGA$data.test$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=3) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:data): nutrimouse", { + + testable.components <- Testable.Components$nutrimouse.block.splsda + GT <- Ground.Truths$nutrimouse.block.splsda + data(nutrimouse) - nrep <- 3 - folds <- 2 - Y = nutrimouse$diet - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) - - nutrimouse.sgccda <- block.splsda(X=data, - Y = Y, - design = design, - keepX = list(gene=c(10,10), lipid=c(15,15)), - ncomp = 2, - scheme = "horst") - - RNGversion(.mixo_rng()) ## in case RNG changes! - set.seed(100) - perf.res12 = perf.sgccda(nutrimouse.sgccda, folds = folds, nrepeat = nrep, auc = TRUE, progressBar = TRUE) - choices <- unname(perf.res12$choice.ncomp$AveragedPredict[,1]) - expect_equal(choices, c(2,2)) - aucs <- round(unname(perf.res12$auc$comp1[,1]), 2) - expect_equal(aucs, c(0.92, 0.74, 0.66, 0.55, 0.69)) - - # with cpus seed must be designated after cluster is created so I made it possible - # by listening to ... in perf for seed. Results are different even with seeds but reproducible with same cpus - # the hassle of making it fully reproducible is a bit too arduous - - perf.res42 = perf(nutrimouse.sgccda, folds = folds, nrepeat = nrep, auc = TRUE, cpus = 2, seed = 100, progressBar = TRUE) - choices <- unname(perf.res42$choice.ncomp$AveragedPredict[,1]) - expect_equal(choices, c(1,1)) - aucs <- round(unname(perf.res42$auc$comp1[,1]), 2) - expect_equal(aucs,c(0.97, 0.66, 0.6, 0.59, 0.79)) + samples <- c(6, 10, 17, 2, 3, 13, 4, 9, 11, 1, 7, 8, 5, 12, 14) + X = list(lipid = nutrimouse$lipid[samples, 1:10], + gene = nutrimouse$gene[samples, 1:10]) + Y = nutrimouse$diet[samples] + + keepX <- list(lipid= c(5,5), + gene = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(101) + block.splsda.perf = perf(res.block.splsda, folds=3) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(perf.diablo:parameter): dist", { + + testable.components <- Testable.Components$dist.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + # max.dist + GT <- Ground.Truths$dist.max.block.splsda + set.seed(101) + block.splsda.perf = perf(res.block.splsda, folds=3, dist = "max.dist") + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + expect_equal(TT, GT) + + # centroids.dist + GT <- Ground.Truths$dist.centroids.block.splsda + set.seed(101) + block.splsda.perf = perf(res.block.splsda, folds=3, dist = "centroids.dist") + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + expect_equal(TT, GT) + + # mahalanobis.dist + GT <- Ground.Truths$dist.mahalanobis.block.splsda + set.seed(101) + block.splsda.perf = perf(res.block.splsda, folds=3, dist = "mahalanobis.dist") + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + expect_equal(TT, GT) }) + + +test_that("(perf.diablo:parameter): validation", { + + testable.components <- Testable.Components$validation.block.splsda + GT <- Ground.Truths$validation.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(101) + block.splsda.perf = perf(res.block.splsda, validation = "loo") + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:parameter): folds", { + + testable.components <- Testable.Components$folds.block.splsda + GT <- Ground.Truths$folds.block.splsda + + data(breast.TCGA) + samples <- c(1:5, 46:50, 79:83) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=5) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:parameter): nrepeat", { + + testable.components <- Testable.Components$nrepeat.block.splsda + GT <- Ground.Truths$nrepeat.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=2, nrepeat = 2) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.diablo:parameter): auc", { + + testable.components <- Testable.Components$auc.block.splsda + GT <- Ground.Truths$auc.block.splsda + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + set.seed(100) + block.splsda.perf = perf(res.block.splsda, folds=3, auc = T) + + invisible(capture.output(TT <- dput(block.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(perf.diablo:error): catches invalid values of validation", { + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + expect_error(perf(res.block.splsda, validation = "random.method"), + "Choose 'validation' among the two following possibilities: 'Mfold' or 'loo'", + fixed=T) +}) + + +test_that("(perf.diablo:error): catches invalid values of folds", { + + data(breast.TCGA) + samples <- c(1:4, 46:49, 79:82) + X = list(miRNA = breast.TCGA$data.train$mirna[samples, 1:10], + mRNA = breast.TCGA$data.train$mrna[samples, 1:10]) + Y = breast.TCGA$data.train$subtype[samples] + + keepX <- list(miRNA= c(5,5), + mRNA = c(5,5)) + + res.block.splsda <- block.splsda(X, Y, keepX = keepX) + + expect_error(perf(res.block.splsda, folds = "random.value"), + "Invalid number of folds.", + fixed=T) + + expect_error(perf(res.block.splsda, folds = 1), + "Invalid number of folds.", + fixed=T) + + expect_error(perf(res.block.splsda, folds = 13), + "Invalid number of folds.", + fixed=T) + + expect_warning(perf(res.block.splsda, folds = 5), + "At least one class is not represented in one fold, which may unbalance the error rate.\n Consider a number of folds lower than the minimum in table(Y): 4", + fixed=T) +}) \ No newline at end of file diff --git a/tests/testthat/test-perf.mint.splsda.R b/tests/testthat/test-perf.mint.splsda.R index bec9cd83..3ec8ee0e 100644 --- a/tests/testthat/test-perf.mint.splsda.R +++ b/tests/testthat/test-perf.mint.splsda.R @@ -1,34 +1,127 @@ -context("tune.mint.splsda") +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### -test_that("perf.mint.splsda works", code = { + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-perf.mint.splsda.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(perf.mint.splsda:basic): mint.plsda", { + + testable.components <- Testable.Components$basic.mint.plsda + GT <- Ground.Truths$basic.mint.plsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + res.mint.plsda <- mint.plsda(X, Y, study=S) + + mint.plsda.perf <- perf(res.mint.plsda) + + invisible(capture.output(TT <- dput(mint.plsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(perf.mint.splsda:basic): mint.splsda", { + + testable.components <- Testable.Components$basic.mint.splsda + GT <- Ground.Truths$basic.mint.splsda + data(stemcells) - res = mint.splsda( - X = stemcells$gene, - Y = stemcells$celltype, - ncomp = 3, - keepX = c(5, 10, 15), - study = stemcells$study - ) - - out = perf(res, auc = FALSE) - expect_is(out, "perf") - expect_true(all(out$choice.ncomp == 1)) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study=S, keepX = choice.keepX) + + mint.splsda.perf <- perf(res.mint.splsda) + invisible(capture.output(TT <- dput(mint.splsda.perf[testable.components]))) + + expect_equal(TT, GT) }) -test_that("perf.mint.splsda works with custom alpha", code = { + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(perf.diablo:parameter): dist", { + + testable.components <- Testable.Components$dist.mint.splsda + data(stemcells) - res = mint.splsda( - X = stemcells$gene, - Y = stemcells$celltype, - ncomp = 3, - keepX = c(5, 10, 15), - study = stemcells$study - ) - - out = perf(res, auc = FALSE, alpha = 0.1) - expect_is(out, "perf") - expect_true(all(out$choice.ncomp == 1)) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study=S, keepX = choice.keepX) + + # max.dist + GT <- Ground.Truths$dist.max.block.splsda + set.seed(101) + mint.splsda.perf = perf(res.mint.splsda, folds=3, dist = "max.dist") + invisible(capture.output(TT <- dput(mint.splsda.perf[testable.components]))) + expect_equal(TT, GT) + + # centroids.dist + GT <- Ground.Truths$dist.centroids.block.splsda + set.seed(101) + mint.splsda.perf = perf(res.mint.splsda, folds=3, dist = "centroids.dist") + invisible(capture.output(TT <- dput(mint.splsda.perf[testable.components]))) + expect_equal(TT, GT) + + # mahalanobis.dist + GT <- Ground.Truths$dist.mahalanobis.block.splsda + set.seed(101) + mint.splsda.perf = perf(res.mint.splsda, folds=3, dist = "mahalanobis.dist") + invisible(capture.output(TT <- dput(mint.splsda.perf[testable.components]))) + expect_equal(TT, GT) }) + + +test_that("(perf.diablo:parameter): auc", { + + testable.components <- Testable.Components$auc.mint.splsda + GT <- Ground.Truths$auc.mint.splsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study=S, keepX = choice.keepX) + + set.seed(100) + mint.splsda.perf = perf(res.mint.splsda, folds=3, auc = T) + + invisible(capture.output(TT <- dput(mint.splsda.perf[testable.components]))) + + expect_equal(TT, GT) +}) \ No newline at end of file diff --git a/tests/testthat/test-plotIndiv.R b/tests/testthat/test-plotIndiv.R index 2910521e..7605769d 100644 --- a/tests/testthat/test-plotIndiv.R +++ b/tests/testthat/test-plotIndiv.R @@ -1,171 +1,628 @@ -context("plotIndiv") -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for rcc", { - data(nutrimouse) - X <- nutrimouse$lipid - Y <- nutrimouse$gene - nutri.res <- rcc(X, Y, ncomp = 3, lambda1 = 0.064, lambda2 = 0.008) - - pl.res <- plotIndiv(nutri.res) - expect_equal(names(pl.res), c("df", "df.ellipse", "graph")) - .expect_numerically_close(pl.res$graph$data$x[1], 0.87088852) - - pl.res <- plotIndiv(nutri.res, rep.space= 'XY-variate', group = nutrimouse$genotype, - legend = TRUE) - .expect_numerically_close(pl.res$graph$data$x[1], 0.8270997) -}) - -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for (s)pls", { - data(liver.toxicity) - X <- liver.toxicity$gene - Y <- liver.toxicity$clinic - toxicity.spls <- spls(X, Y, ncomp = 3, keepX = c(50, 50, 50), - keepY = c(10, 10, 10)) - - pl.res <- plotIndiv(toxicity.spls, rep.space="X-variate", ind.name = FALSE, - group = liver.toxicity$treatment[, 'Time.Group'], - pch = as.numeric(factor(liver.toxicity$treatment$Dose.Group)), - pch.levels =liver.toxicity$treatment$Dose.Group, - legend = TRUE) - .expect_numerically_close(pl.res$graph$data$x[1], 4.146771) -}) - -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for (s)plsda", { - data(breast.tumors) - X <- breast.tumors$gene.exp - Y <- breast.tumors$sample$treatment - - splsda.breast <- splsda(X, Y,keepX=c(10,10),ncomp=2) - - pl.res <- plotIndiv(splsda.breast) - .expect_numerically_close(pl.res$graph$data$x[1], -1.075222) -}) - -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for (s)pls", { - data(liver.toxicity) - X <- liver.toxicity$gene - Y <- liver.toxicity$clinic - toxicity.spls <- spls(X, Y, ncomp = 3, keepX = c(50, 50, 50), - keepY = c(10, 10, 10)) - - pl.res <- plotIndiv(toxicity.spls, rep.space="X-variate", ind.name = FALSE, - group = liver.toxicity$treatment[, 'Time.Group'], - pch = as.numeric(factor(liver.toxicity$treatment$Dose.Group)), - pch.levels =liver.toxicity$treatment$Dose.Group, - legend = TRUE) - .expect_numerically_close(pl.res$graph$data$x[1], 4.146771) -}) -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for mint.(s)plsda", { - data(stemcells) - res = mint.splsda(X = stemcells$gene, Y = stemcells$celltype, ncomp = 2, keepX = c(10, 5), - study = stemcells$study) - - pl.res <- plotIndiv(res) - .expect_numerically_close(pl.res$graph$data$x[1], -1.543685) -}) -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for sgcca and rgcca", { - data(nutrimouse) - Y = unmap(nutrimouse$diet) - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid, Y = Y) - design1 = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) - nutrimouse.sgcca <- wrapper.sgcca(X = data, - design = design1, - penalty = c(0.3, 0.5, 1), - ncomp = 3, - scheme = "horst") - - pl.res <- plotIndiv(nutrimouse.sgcca) - .expect_numerically_close(pl.res$graph$data$x[1], 3.319955) -}) - -## ------------------------------------------------------------------------ ## -test_that("plotIndiv works for sgccda", { - data(nutrimouse) - Y = nutrimouse$diet - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design1 = matrix(c(0,1,0,1), ncol = 2, nrow = 2, byrow = TRUE) - - nutrimouse.sgccda1 <- wrapper.sgccda(X = data, - Y = Y, - design = design1, - ncomp = 2, - keepX = list(gene = c(10,10), lipid = c(15,15)), - scheme = "centroid") - pl.res <- plotIndiv(nutrimouse.sgccda1) - - .expect_numerically_close(pl.res$graph$data$x[1], 2.448086) -}) - -test_that("plotIndiv.rcc works without ind.names", code = { - data(nutrimouse) - X <- nutrimouse$lipid - Y <- nutrimouse$gene - nutri.res <- rcc(X, Y, ncomp = 3, lambda1 = 0.064, lambda2 = 0.008) + + +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# edge cases +## "'col' is ignored as 'group' has been set." + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-plotIndiv.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(plotIndiv:basic): pca", { - plotIndiv.res <- plotIndiv(nutri.res, group = nutrimouse$genotype, ind.names = FALSE, legend = TRUE) + testable.components <- Testable.Components$basic.pca + GT <- Ground.Truths$basic.pca - expect_is(plotIndiv.res$graph, "ggplot") + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X) + + pca.plotIndiv = plotIndiv(res.pca)$graph + + invisible(capture.output(TT <- dput(pca.plotIndiv[testable.components]))) + + expect_equal(TT, GT) }) -## ------------------------------------------------------------------------ ## -test_that("plotIndiv.sgcca(..., blocks = 'average') works", code = { +test_that("(plotIndiv:basic): spca", { + + testable.components <- Testable.Components$basic.spca + GT <- Ground.Truths$basic.spca + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + choice.keepX <- c(3,3) + + res.spca <- spca(X, keepX = choice.keepX) + + spca.plotIndiv = plotIndiv(res.spca)$graph + + invisible(capture.output(TT <- dput(spca.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): pls", { + + testable.components <- Testable.Components$basic.pls + GT <- Ground.Truths$basic.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10, ] + Y <- liver.toxicity$clinic[1:10, ] + + res.pls <- pls(X, Y) + + pls.plotIndiv = plotIndiv(res.pls)$graph + + invisible(capture.output(TT <- dput(pls.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): spls", { + + testable.components <- Testable.Components$basic.spls + GT <- Ground.Truths$basic.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10, ] + Y <- liver.toxicity$clinic[1:10, ] + + choice.keepX <- c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX) + + spls.plotIndiv = plotIndiv(res.spls)$graph + + invisible(capture.output(TT <- dput(spls.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): rcc", { + + testable.components <- Testable.Components$basic.rcc + GT <- Ground.Truths$basic.rcc + data(nutrimouse) - Y = unmap(nutrimouse$diet) - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid, Y = Y) - design1 = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) - nutrimouse.sgcca <- wrapper.sgcca(X = data, - design = design1, - penalty = c(0.3, 0.5, 1), - ncomp = 2, - scheme = "horst") - - # default style: one panel for each block - plotindiv_res <- plotIndiv(nutrimouse.sgcca, blocks = c("lipid","average")) - - expect_true(any(grepl(pattern = "average", x = unique(plotindiv_res$df$Block)))) -}) - -## ------------------------------------------------------------------------ ## - -test_that("plotIndiv.sgccda(..., blocks = 'average') works with ind.names and ell", code = { - data("breast.TCGA") - data = list(mrna = breast.TCGA$data.train$mrna, mirna = breast.TCGA$data.train$mirna, - protein = breast.TCGA$data.train$protein) - design = matrix(1, ncol = length(data), nrow = length(data), - dimnames = list(names(data), names(data))) - diag(design) = 0 - # set number of variables to select, per component and per data set (this is set arbitrarily) - list.keepX = list(mrna = rep(4, 2), mirna = rep(5,2), protein = rep(5, 2)) - TCGA.block.splsda = block.splsda(X = data, Y = breast.TCGA$data.train$subtype, - ncomp = 2, keepX = list.keepX, design = design) - blocks <- c("average", "mrna", "weighted.average") - diablo_plot <- plotIndiv(TCGA.block.splsda, ind.names = FALSE, blocks = blocks) - expect_true(all(unique(diablo_plot$df$Block) %in% c('average', 'Block: mrna', 'average (weighted)'))) -}) - -## ------------------------------------------------------------------------ ## - -test_that("plotIndiv.sgccda(..., blocks = 'average') works with ellipse=TRUE", code = { - data("breast.TCGA") - data = list(mrna = breast.TCGA$data.train$mrna, mirna = breast.TCGA$data.train$mirna, - protein = breast.TCGA$data.train$protein) - design = matrix(1, ncol = length(data), nrow = length(data), - dimnames = list(names(data), names(data))) - diag(design) = 0 - # set number of variables to select, per component and per data set (this is set arbitrarily) - list.keepX = list(mrna = rep(4, 2), mirna = rep(5,2), protein = rep(5, 2)) - TCGA.block.splsda = block.splsda(X = data, Y = breast.TCGA$data.train$subtype, - ncomp = 2, keepX = list.keepX, design = design) - blocks <- c("average", "mrna", "weighted.average") - diablo_plot <- plotIndiv(TCGA.block.splsda, ind.names = TRUE, blocks = blocks, ellipse = TRUE) - expect_true(all(unique(diablo_plot$df.ellipse$Block) %in% c('average', 'Block: mrna', 'average (weighted)'))) + X <- nutrimouse$lipid[1:10, ] + Y <- nutrimouse$gene[1:10, ] + + res.rcc <- rcc(X, Y, method = "shrinkage") + + rcc.plotIndiv = plotIndiv(res.rcc)$graph + + invisible(capture.output(TT <- dput(rcc.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + data(srbct) + samples <- c(1:3, 24:26, 41:43) + X <- srbct$gene[samples,] + Y <- srbct$class[samples] + + res.plsda <- plsda(X, Y) + + plsda.plotIndiv = plotIndiv(res.plsda)$graph + + invisible(capture.output(TT <- dput(plsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + data(srbct) + samples <- c(1:3, 24:26, 41:43) + X <- srbct$gene[samples,] + Y <- srbct$class[samples] + + choice.keepX = c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + splsda.plotIndiv = plotIndiv(res.splsda)$graph + + invisible(capture.output(TT <- dput(splsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): block.plsda", { + + testable.components <- Testable.Components$basic.block.plsda + GT <- Ground.Truths$basic.block.plsda + + data(breast.TCGA) + samples <- c(1:3, 22:25, 36:38) + X = list(miRNA = breast.TCGA$data.test$mirna[samples,], + mRNA = breast.TCGA$data.test$mrna[samples,]) + Y = breast.TCGA$data.test$subtype[samples] + + res.block.plsda <- block.plsda(X, Y) + + block.plsda.plotIndiv = plotIndiv(res.block.plsda)$graph + + invisible(capture.output(TT <- dput(block.plsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): block.splsda", { + + testable.components <- Testable.Components$basic.block.splsda + GT <- Ground.Truths$basic.block.splsda + + data(breast.TCGA) + samples <- c(1:3, 22:25, 36:38) + X = list(miRNA = breast.TCGA$data.test$mirna[samples,], + mRNA = breast.TCGA$data.test$mrna[samples,]) + Y = breast.TCGA$data.test$subtype[samples] + + choice.keepX = list(miRNA=c(3,3), + mRNA=c(3,3)) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + block.splsda.plotIndiv = plotIndiv(res.block.splsda)$graph + + invisible(capture.output(TT <- dput(block.splsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): mint.pls", { + + testable.components <- Testable.Components$basic.mint.pls + GT <- Ground.Truths$basic.mint.pls + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- stemcells$gene[samples+5, 1:10] + S <- as.character(stemcells$study[samples]) + + res.mint.pls <- mint.pls(X, Y, study = S) + + mint.pls.plotIndiv = plotIndiv(res.mint.pls)$graph + + invisible(capture.output(TT <- dput(mint.pls.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): mint.spls", { + + testable.components <- Testable.Components$basic.mint.spls + GT <- Ground.Truths$basic.mint.spls + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- stemcells$gene[samples+5, 1:10] + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.spls <- mint.spls(X, Y, study = S, keepX = choice.keepX) + + mint.spls.plotIndiv = plotIndiv(res.mint.spls)$graph + + invisible(capture.output(TT <- dput(mint.spls.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): mint.plsda", { + + testable.components <- Testable.Components$basic.mint.plsda + GT <- Ground.Truths$basic.mint.plsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + res.mint.plsda <- mint.plsda(X, Y, study = S) + + mint.plsda.plotIndiv = plotIndiv(res.mint.plsda)$graph + + invisible(capture.output(TT <- dput(mint.plsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:basic): mint.splsda", { + + testable.components <- Testable.Components$basic.mint.splsda + GT <- Ground.Truths$basic.mint.splsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study = S, keepX = choice.keepX) + + mint.splsda.plotIndiv = plotIndiv(res.mint.splsda)$graph + + invisible(capture.output(TT <- dput(mint.splsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(plotIndiv:parameter): comp", { + + testable.components <- Testable.Components$comp.pca + GT <- Ground.Truths$comp.pca + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X, ncomp = 3) + + pca.plotIndiv = plotIndiv(res.pca, comp = c(2,3))$graph + + invisible(capture.output(TT <- dput(pca.plotIndiv[testable.components]))) + + expect_equal(TT, GT) }) + +test_that("(plotIndiv:parameter): study", { + + testable.components <- Testable.Components$study.mint.splsda + GT <- Ground.Truths$study.mint.splsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study = S, keepX = choice.keepX) + + mint.splsda.plotIndiv = plotIndiv(res.mint.splsda, study = "all.partial")$graph + + invisible(capture.output(TT <- dput(mint.splsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:parameter): ellipse", { + + testable.components <- Testable.Components$ellipse.splsda + GT <- Ground.Truths$ellipse.splsda + + data(srbct) + samples <- c(1:3, 24:26, 41:43) + X <- srbct$gene[samples,] + Y <- srbct$class[samples] + + choice.keepX = c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + splsda.plotIndiv = plotIndiv(res.splsda, ellipse = T) + + invisible(capture.output(TT <- dput(splsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:parameter): blocks", { + + testable.components <- Testable.Components$blocks.block.plsda + GT <- Ground.Truths$blocks.block.plsda + + data(breast.TCGA) + samples <- c(1:3, 22:25, 36:38) + X = list(miRNA = breast.TCGA$data.test$mirna[samples,], + mRNA = breast.TCGA$data.test$mrna[samples,]) + Y = breast.TCGA$data.test$subtype[samples] + + res.block.plsda <- block.plsda(X, Y) + + block.plsda.plotIndiv = plotIndiv(res.block.plsda, blocks = "mRNA")$graph + + invisible(capture.output(TT <- dput(block.plsda.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotIndiv:parameter): ind.names", { + + testable.components <- Testable.Components$ind.names.pca + GT <- Ground.Truths$ind.names.pca + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X) + + pca.plotIndiv = plotIndiv(res.pca, ind.names = F)$graph + + invisible(capture.output(TT <- dput(pca.plotIndiv[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(plotIndiv:error): catches invalid style values", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X) + + expect_error(plotIndiv(res.pca, style = "random.style"), + "'style' must be one of 'ggplot2', 'lattice', 'graphics' or '3d' .", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid ellipse/ellipse.level values", { + + data(srbct) + samples <- c(1:3, 24:26, 41:43) + X <- srbct$gene[samples,] + Y <- srbct$class[samples] + + choice.keepX = c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + expect_error(plotIndiv(res.splsda, ellipse = "random.value"), + "'ellipse' must be either TRUE or FALSE", + fixed=T) + + expect_error(plotIndiv(res.splsda, ellipse.level = -1), + "The value taken by 'ellipse.level' must be between 0 and 1", + fixed=T) + + expect_error(plotIndiv(res.splsda, ellipse.level = 2), + "The value taken by 'ellipse.level' must be between 0 and 1", + fixed=T) + + expect_error(plotIndiv(res.splsda, ellipse.level = "random.value"), + "The value taken by 'ellipse.level' must be between 0 and 1", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid alpha values", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X) + + expect_error(plotIndiv(res.pca, alpha = "random.value"), + "The value taken by 'alpha' must be between 0 and 1", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid comp values", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X, ncomp = 5) + + expect_error(plotIndiv(res.pca, comp = c(1)), + "'comp' must be a numeric vector of length 2.", + fixed=T) + + expect_error(plotIndiv(res.pca, comp = c(1,2,3)), + "'comp' must be a numeric vector of length 2.", + fixed=T) + + expect_error(plotIndiv(res.pca, style = "3d", comp = c(1,2)), + "'comp' must be a numeric vector of length 3.", + fixed=T) + + expect_error(plotIndiv(res.pca, style = "3d", comp = c(1,2,3,4)), + "'comp' must be a numeric vector of length 3.", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid ind.names values", { + + data(multidrug) + X <- multidrug$ABC.trans[1:10, 1:10] + + res.pca <- pca(X, ncomp = 5) + + expect_error(plotIndiv(res.pca, ind.names = c("random.name.1", "random.name.2")), + "'ind.names' must be a character vector of length 10 or a Logical atomic vector.", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid xlim/ylim values", { + + data(breast.TCGA) + samples <- c(1:3, 22:25, 36:38) + X = list(miRNA = breast.TCGA$data.train$mirna[samples,], + mRNA = breast.TCGA$data.train$mrna[samples,], + proteomics = breast.TCGA$data.train$protein[samples,]) + Y = breast.TCGA$data.test$subtype[samples] + + res.block.plsda <- block.plsda(X, Y) + + expect_error(plotIndiv(res.block.plsda, style="lattice", blocks = c("miRNA", "mRNA", "proteomics"), + ylim = list(miRNA = c(-15,15), + mRNA = c(-15,15))), + "'ylim' must be a list of 3 vectors of length 2.", + fixed=T) + + expect_error(plotIndiv(res.block.plsda, blocks = "mRNA", + ylim = c(-30, 0, 30)), + "'ylim' must be a vector of length 2.", + fixed=T) + + expect_error(plotIndiv(res.block.plsda, style="lattice", blocks = c("miRNA", "mRNA", "proteomics"), + xlim = list(miRNA = c(-15,15), + mRNA = c(-15,15))), + "'xlim' must be a list of 3 vectors of length 2.", + fixed=T) + + expect_error(plotIndiv(res.block.plsda, blocks = "mRNA", + xlim = c(-30, 0, 30)), + "'xlim' must be a vector of length 2.", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid col values", { + + data(srbct) + samples <- c(1:3, 24:26, 41:43) + X <- srbct$gene[samples,] + Y <- srbct$class[samples] + + res.plsda <- plsda(X, Y) + + expect_error(plotIndiv(res.plsda, col=c("#388ECC", "#F68B33")), + "Length of 'col' should be of length 3 (the number of groups).", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid col.per.group values", { + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10,] + Y <- liver.toxicity$clinic[1:10,] + + res.pls <- pls(X, Y) + + group <- c(rep("c1", 5), rep("c2", 5)) + + expect_error(plotIndiv(res.pls, group = group, col.per.group = c("#388ECC", "#F68B33", "#cc7638")), + "Length of 'col.per.group' should be of length 2 (the number of groups).", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches invalid pch values when using MINT", { + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX <- c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study = S, keepX = choice.keepX) + + expect_error(plotIndiv(res.mint.splsda, pch = c(0,1,2)), + "'pch' needs to be of length 'object$study' as each of 'pch' represents a specific study", + fixed=T) +}) + + +test_that("(plotIndiv:error): catches use of mint.block.(s)pls(da) as invalid", { + + data(breast.TCGA) + mrna = rbind(breast.TCGA$data.train$mrna, breast.TCGA$data.test$mrna) + mirna = rbind(breast.TCGA$data.train$mirna, breast.TCGA$data.test$mirna) + X = list(mrna = mrna, mirna = mirna) + Y = c(breast.TCGA$data.train$subtype, breast.TCGA$data.test$subtype) + S = c(rep("study1",150), rep("study2",70)) + + res.mint.block.plsda <- mint.block.plsda(X, Y, study = S) + + expect_error(plotIndiv(res.mint.block.plsda), + "No plotIndiv for the following functions at this stage: mint.block.pls, mint.block.spls, mint.block.plsda, mint.block.splsda.", + fixed=T) +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(plotIndiv:warning): warned that col is ignored when group is supplied", { + + data(liver.toxicity) + X <- liver.toxicity$gene[1:10,] + Y <- liver.toxicity$clinic[1:10,] + + res.pls <- pls(X, Y) + + group <- c(rep("c1", 5), rep("c2", 5)) + + expect_warning(plotIndiv(res.pls, group = group, + col.per.group = c("#388ECC", "#F68B33"), + col = c("#388ECC", "#F68B33")), + "'col' is ignored as 'group' has been set.", + fixed=T) +}) + + +############################################################################### + +dev.off() unlink(list.files(pattern = "*.pdf")) diff --git a/tests/testthat/test-plotLoadings.R b/tests/testthat/test-plotLoadings.R index 0845ce6d..d8b388c0 100644 --- a/tests/testthat/test-plotLoadings.R +++ b/tests/testthat/test-plotLoadings.R @@ -1,99 +1,534 @@ -context("plotLoadings") -test_that("plotLoadings.spls works", code = { +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# basic +## mint.pls - add down the line once PR #212 is merged +## mint.spls - add down the line once PR #212 is merged + +# parameter +## block - add down the line once PR #212 is merged + +# error +## "Duplicate in 'study' not allowed" - add down the line once PR #212 is merged +## "'study' must be one of 'object$study' or 'all'." - add down the line once PR #212 is merged + +# edge cases +## + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-plotLoadings.rda", package = "mixOmics")) +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(plotLoadings:basic): pca", { + + GT <- Ground.Truths$basic.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + pca.plotLoadings = plotLoadings(res.pca) + + invisible(capture.output(TT <- dput(pca.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): spca", { + + GT <- Ground.Truths$basic.spca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + choice.keepX <- c(3,3) + + res.spca <- spca(X, keepX = choice.keepX) + + spca.plotLoadings = plotLoadings(res.spca) + + invisible(capture.output(TT <- dput(spca.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): pls", { + + GT <- Ground.Truths$basic.pls + data(liver.toxicity) - X = liver.toxicity$gene - Y = liver.toxicity$clinic + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] - toxicity.spls = spls(X, Y, ncomp = 2, keepX = c(50, 50), - keepY = c(10, 10)) + res.pls <- pls(X, Y) - pl_res <- plotLoadings(toxicity.spls) + pls.plotLoadings = plotLoadings(res.pls) - expect_is(pl_res, "list") + invisible(capture.output(TT <- dput(pls.plotLoadings))) + expect_equal(TT, GT) }) -test_that("plotLoadings.splsda works", code = { + +test_that("(plotLoadings:basic): spls", { + + GT <- Ground.Truths$basic.spls + data(liver.toxicity) - X = as.matrix(liver.toxicity$gene) - Y = as.factor(liver.toxicity$treatment[, 4]) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + choice.keepX <- c(3,3) + choice.keepY <- c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX, keepY = choice.keepY) + + spls.plotLoadings = plotLoadings(res.spls) + + invisible(capture.output(TT <- dput(spls.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): plsda", { + + GT <- Ground.Truths$basic.plsda + + data(srbct) + X <- srbct$gene[,1:10] + Y <- srbct$class + + res.plsda <- plsda(X, Y) + + plsda.plotLoadings = plotLoadings(res.plsda) + + invisible(capture.output(TT <- dput(plsda.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): splsda", { - splsda.liver = splsda(X, Y, ncomp = 2, keepX = c(20, 20)) + GT <- Ground.Truths$basic.splsda + + data(srbct) + X <- srbct$gene[,1:10] + Y <- srbct$class + + choice.keepX <- c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + splsda.plotLoadings = plotLoadings(res.splsda) + + invisible(capture.output(TT <- dput(splsda.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): block.pls", { + + GT <- Ground.Truths$basic.block.pls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + + res.block.pls <- block.pls(X, indY = 3) + + block.pls.plotLoadings = plotLoadings(res.block.pls) + + invisible(capture.output(TT <- dput(block.pls.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): block.spls", { + + GT <- Ground.Truths$basic.block.spls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.spls <- block.spls(X, indY = 3, keepX = choice.keepX) + + block.spls.plotLoadings = plotLoadings(res.block.spls) + + invisible(capture.output(TT <- dput(block.spls.plotLoadings))) + + expect_equal(TT, GT) +}) + - pl_res <- plotLoadings(splsda.liver, comp = 1, method = 'median') +test_that("(plotLoadings:basic): block.plsda", { + + GT <- Ground.Truths$basic.block.plsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype - expect_is(pl_res, "list") + res.block.plsda <- block.plsda(X, Y) + block.plsda.plotLoadings = plotLoadings(res.block.plsda) + + invisible(capture.output(TT <- dput(block.plsda.plotLoadings))) + + expect_equal(TT, GT) }) -test_that("plotLoadings.block.splsda works", code = { - data(nutrimouse) - Y = nutrimouse$diet - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) + +test_that("(plotLoadings:basic): block.splsda", { - nutrimouse.sgccda = wrapper.sgccda(X = data, - Y = Y, - design = design, - keepX = list(gene = c(10,10), lipid = c(15,15)), - ncomp = 2, - scheme = "centroid") + GT <- Ground.Truths$basic.block.splsda - pl_res <- plotLoadings(nutrimouse.sgccda,block=2) + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype - expect_is(pl_res, "list") + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + block.splsda.plotLoadings = plotLoadings(res.block.splsda) + + invisible(capture.output(TT <- dput(block.splsda.plotLoadings))) + + expect_equal(TT, GT) }) -test_that("plotLoadings.mint.splsda works", code = { + +test_that("(plotLoadings:basic): mint.plsda", { + + GT <- Ground.Truths$basic.mint.plsda + data(stemcells) - data = stemcells$gene - type.id = stemcells$celltype - exp = stemcells$study + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + res.mint.plsda <- mint.plsda(X, Y, study = S) + + mint.plsda.plotLoadings = plotLoadings(res.mint.plsda) + + invisible(capture.output(TT <- dput(mint.plsda.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:basic): mint.splsda", { + + GT <- Ground.Truths$basic.mint.splsda + + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX = c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study = S, keepX = choice.keepX) + + mint.splsda.plotLoadings = plotLoadings(res.mint.splsda) + + invisible(capture.output(TT <- dput(mint.splsda.plotLoadings))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(plotLoadings:parameter): comp", { + + GT <- Ground.Truths$comp.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + comp.plotLoadings = plotLoadings(res.pca, comp = 2) + + invisible(capture.output(TT <- dput(comp.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:parameter): ndisplay", { + + # test ndisplay using single omics type + + GT <- Ground.Truths$ndisplay.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] - res = mint.splsda(X = data, Y = type.id, ncomp = 3, keepX = c(10,5,15), study = exp) - pl_res <- plotLoadings(res, contrib = "max") + res.pca <- pca(X) - expect_is(pl_res, "list") + ndisplay.plotLoadings = plotLoadings(res.pca, ndisplay = 3) + invisible(capture.output(TT <- dput(ndisplay.plotLoadings))) + + expect_equal(TT, GT) + + # ------------------------------------------------------------- # + # test ndisplay using multi omics type + + GT <- Ground.Truths$ndisplay.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.pls <- pls(X, Y) + + ndisplay.plotLoadings = plotLoadings(res.pls, ndisplay = 3) + + invisible(capture.output(TT <- dput(ndisplay.plotLoadings))) + + expect_equal(TT, GT) }) -test_that("plotLoadings.mint.spls works", code = { +test_that("(plotLoadings:parameter): contrib/method", { + + GT <- Ground.Truths$contrib.method.plsda + + data(srbct) + X <- srbct$gene[,1:5] + Y <- srbct$class + + res.plsda <- plsda(X, Y) + + contrib.method.plotLoadings = plotLoadings(res.plsda, contrib = "max", + method = "median") + + invisible(capture.output(TT <- dput(contrib.method.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:parameter): study", { + + GT <- Ground.Truths$study.mint.plsda + data(stemcells) samples <- c(1:5,60:64) X <- stemcells$gene[samples, 1:10] - Y <- stemcells$gene[samples+5, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) S <- as.character(stemcells$study[samples]) + + res.mint.plsda <- mint.plsda(X, Y, study = S) + + study.plotLoadings = plotLoadings(res.mint.plsda, study = "1") + + invisible(capture.output(TT <- dput(study.plotLoadings))) + + expect_equal(TT, GT) +}) + + +test_that("(plotLoadings:parameter): name.var", { + + GT <- Ground.Truths$name.var.block.plsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype - res = mint.spls(X = X, Y = Y, ncomp = 3, - keepX = seq(3, 9, 3), - keepY = seq(3, 9, 3), - study = S) - pl_res <- plotLoadings(res, contrib = "max") + res.block.plsda <- block.plsda(X, Y) - expect_is(pl_res, "list") + n <- list(miRNA = rep("miRNA.names", 10), + mRNA = rep("mRNA.names", 10), + proteomics = rep("protein.names", 10)) + + name.var.plotLoadings = plotLoadings(res.block.plsda, name.var = n) + + invisible(capture.output(TT <- dput(name.var.plotLoadings))) + + expect_equal(TT, GT) }) -test_that("plotLoadings margin errrors is handled properly", code = { - data(nutrimouse) - Y = nutrimouse$diet - gene = nutrimouse$gene - lipid = nutrimouse$lipid - ## extend feature names - suff <- "-a-long-suffix-from-abolutely-nowhere-which-is-gonna-be-longer-than-margins" - colnames(gene) <- paste0(colnames(gene), suff) - colnames(lipid) <- paste0(colnames(lipid), suff) - data = list(gene = gene, lipid = lipid) - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + + +test_that("(plotLoadings:error): catches object with no loading values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + res.pca$loadings <- NULL - nutrimouse.sgccda = block.splsda(X = data, - Y = Y, - design = design, - keepX = list(gene = c(10,10), lipid = c(15,15)), - ncomp = 2, - scheme = "centroid") - expect_error(plotLoadings(nutrimouse.sgccda, contrib = "min"), regexp = "plotLoadings encountered margin errors") + expect_error(plotLoadings(res.pca), + "'plotLoadings' should be used on object for which object$loadings is present.", + fixed=T) }) + + +test_that("(plotLoadings:error): catches invalid `block` values", { + + data(srbct) + X <- srbct$gene[,1:10] + Y <- srbct$class + + res.plsda <- plsda(X, Y) + + expect_error(plotLoadings(res.plsda, block = 2), + "'block' can only be 'X' or '1' for plsda and splsda object", + fixed=T) + + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y) + + expect_error(plotLoadings(res.block.plsda, block = 4), + "'block' needs to be lower than the number of blocks in the fitted model, which is 3", + fixed=T) + + expect_error(plotLoadings(res.block.plsda, block = "random.block"), + "Incorrect value for 'block', 'block' should be among the blocks used in your object: miRNA, mRNA, proteomics", + fixed=T) +}) + + +test_that("(plotLoadings:error): catches invalid `contrib` values", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y) + + expect_error(plotLoadings(res.block.plsda, contrib = "random.value"), + "'contrib' must be either 'min' or 'max'", + fixed=T) +}) + + +test_that("(plotLoadings:error): catches invalid `name.var` values", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y) + + expect_error(plotLoadings(res.block.plsda, name.var = list(miRNA = rep("miRNA.names", 10), + mRNA = rep("mRNA.names", 10), + proteomics = rep("protein.names", 9))), + "For block 'proteomics', 'name.var' should be a vector of length 10", + fixed=T) + + expect_error(plotLoadings(res.block.plsda, name.var = list(miRNA = rep("miRNA.names", 10), + mRNA = rep("mRNA.names", 10))), + "'names' has to be a list of length the number of block to plot: 3", + fixed=T) +}) + + +# test_that("(plotLoadings:error): catches if study has duplicate entries", { +# +# data(stemcells) +# samples <- c(1:5,60:64) +# X <- stemcells$gene[samples, 1:10] +# Y <- rep(c("hESC", "hiPSC"),5) +# S <- as.character(stemcells$study[samples]) +# +# res.mint.plsda <- mint.plsda(X, Y, study = S) +# +# expect_error(plotLoadings(res.mint.plsda, study = c("1", "1")), +# "Duplicate in 'study' not allowed", +# fixed=T) +# }) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + + + + +############################################################################### + +dev.off() +unlink(list.files(pattern = "*.pdf")) + + +# +# test_that("plotLoadings margin errrors is handled properly", code = { +# data(nutrimouse) +# Y = nutrimouse$diet +# gene = nutrimouse$gene +# lipid = nutrimouse$lipid +# ## extend feature names +# suff <- "-a-long-suffix-from-abolutely-nowhere-which-is-gonna-be-longer-than-margins" +# colnames(gene) <- paste0(colnames(gene), suff) +# colnames(lipid) <- paste0(colnames(lipid), suff) +# data = list(gene = gene, lipid = lipid) +# design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, byrow = TRUE) +# +# nutrimouse.sgccda = block.splsda(X = data, +# Y = Y, +# design = design, +# keepX = list(gene = c(10,10), lipid = c(15,15)), +# ncomp = 2, +# scheme = "centroid") +# expect_error(plotLoadings(nutrimouse.sgccda, contrib = "min"), regexp = "plotLoadings encountered margin errors") +# }) \ No newline at end of file diff --git a/tests/testthat/test-plotVar.R b/tests/testthat/test-plotVar.R index f052dee1..76db5fe4 100644 --- a/tests/testthat/test-plotVar.R +++ b/tests/testthat/test-plotVar.R @@ -1,29 +1,690 @@ -context("plotVar") -## ------------------------------------------------------------------------ ## -test_that("plotVar works for pls with var.names", { - data(nutrimouse) - x <- nutrimouse$gene - y <- nutrimouse$lipid - ## custom var.names - var.names <- list(x = seq_along(x), y = seq_along(y)) - - pls.res <- pls(x, y) - df <- plotVar(pls.res , var.names = var.names, plot = FALSE) - - var.names.char.vec <- unname(unlist(lapply(var.names, as.character))) - - expect_true(all(df$names == var.names.char.vec)) - - ## ------------- spls - spls.res <- spls(x, y , keepX = c(10, 10)) - df <- plotVar(spls.res , var.names = var.names, plot = FALSE) - expect_true(is(df, 'data.frame')) - expect_true(all(df$names %in% as.character(unlist(var.names)))) - - ## ------------- spca - var.names = list(seq_along(x)) - spca.res <- spca(x, keepX = c(10, 10)) - df <- plotVar(spca.res, var.names = var.names, plot = FALSE) - expect_true(all(df$names %in% as.character(unlist(var.names)))) - + +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# edge cases +## "We detected negative correlation between the variates of some blocks, which means that some clusters of variables observed on the correlation circle plot are not necessarily positively correlated." + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-plotVar.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(plotVar:basic): pca", { + + testable.components <- Testable.Components$basic.pca + GT <- Ground.Truths$basic.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + pca.plotVar = plotVar(res.pca) + + invisible(capture.output(TT <- dput(pca.plotVar[testable.components]))) + + expect_equal(TT, GT) }) + + +test_that("(plotVar:basic): spca", { + + testable.components <- Testable.Components$basic.spca + GT <- Ground.Truths$basic.spca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + choice.keepX = c(3,3) + + res.spca <- spca(X, keepX = choice.keepX) + + spca.plotVar = plotVar(res.spca) + + invisible(capture.output(TT <- dput(spca.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): pls", { + + testable.components <- Testable.Components$basic.pls + GT <- Ground.Truths$basic.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + res.pls <- pls(X, Y) + + pls.plotVar = plotVar(res.pls) + + invisible(capture.output(TT <- dput(pls.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): spls", { + + testable.components <- Testable.Components$basic.spls + GT <- Ground.Truths$basic.spls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:10] + Y <- liver.toxicity$clinic[,1:10] + + choice.keepX = c(3,3) + + res.spls <- spls(X, Y, keepX = choice.keepX) + + spls.plotVar = plotVar(res.spls) + + invisible(capture.output(TT <- dput(spls.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): rcc", { + + testable.components <- Testable.Components$basic.rcc + GT <- Ground.Truths$basic.rcc + + data(nutrimouse) + X <- nutrimouse$lipid[,1:10] + Y <- nutrimouse$gene[,1:10] + + res.rcc <- rcc(X, Y) + + rcc.plotVar = plotVar(res.rcc) + + invisible(capture.output(TT <- dput(rcc.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + data(srbct) + X <- srbct$gene[,1:10] + Y <- srbct$class + + res.plsda <- plsda(X, Y) + + plsda.plotVar = plotVar(res.plsda) + + invisible(capture.output(TT <- dput(plsda.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + data(srbct) + X <- srbct$gene[,1:10] + Y <- srbct$class + + choice.keepX = c(3,3) + + res.splsda <- splsda(X, Y, keepX = choice.keepX) + + splsda.plotVar = plotVar(res.splsda) + + invisible(capture.output(TT <- dput(splsda.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +# test_that("(plotVar:basic): block.pls", { +# +# testable.components <- Testable.Components$basic.block.pls +# GT <- Ground.Truths$basic.block.pls +# +# data(breast.TCGA) +# X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], +# mRNA = breast.TCGA$data.train$mrna[,1:10], +# proteomics = breast.TCGA$data.train$protein[,1:10]) +# +# res.block.pls <- block.pls(X, indY=3) +# +# block.pls.plotVar = plotVar(res.block.pls) +# +# invisible(capture.output(TT <- dput(block.pls.plotVar[testable.components]))) +# +# expect_equal(TT, GT) +# }) +# +# +# test_that("(plotVar:basic): block.spls", { +# +# testable.components <- Testable.Components$basic.block.spls +# GT <- Ground.Truths$basic.block.spls +# +# data(breast.TCGA) +# X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], +# mRNA = breast.TCGA$data.train$mrna[,1:10], +# proteomics = breast.TCGA$data.train$protein[,1:10]) +# +# choice.keepX = list(miRNA = c(3,3), +# mRNA = c(3,3), +# proteomics = c(3,3)) +# +# res.block.spls <- block.spls(X, indY=3, keepX = choice.keepX) +# +# block.spls.plotVar = plotVar(res.block.spls) +# +# invisible(capture.output(TT <- dput(block.spls.plotVar[testable.components]))) +# +# expect_equal(TT, GT) +# }) +# +# +# test_that("(plotVar:basic): block.plsda", { +# +# testable.components <- Testable.Components$basic.block.plsda +# GT <- Ground.Truths$basic.block.plsda +# +# data(breast.TCGA) +# X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], +# mRNA = breast.TCGA$data.train$mrna[,1:10], +# proteomics = breast.TCGA$data.train$protein[,1:10]) +# Y = breast.TCGA$data.train$subtype +# +# res.block.plsda <- block.plsda(X, Y) +# +# block.plsda.plotVar = plotVar(res.block.plsda) +# +# invisible(capture.output(TT <- dput(block.plsda.plotVar[testable.components]))) +# +# expect_equal(TT, GT) +# }) +# +# +# test_that("(plotVar:basic): block.splsda", { +# +# testable.components <- Testable.Components$basic.block.splsda +# GT <- Ground.Truths$basic.block.splsda +# +# data(breast.TCGA) +# X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], +# mRNA = breast.TCGA$data.train$mrna[,1:10], +# proteomics = breast.TCGA$data.train$protein[,1:10]) +# Y = breast.TCGA$data.train$subtype +# +# choice.keepX = list(miRNA = c(3,3), +# mRNA = c(3,3), +# proteomics = c(3,3)) +# +# res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) +# +# block.splsda.plotVar = plotVar(res.block.splsda) +# +# invisible(capture.output(TT <- dput(block.splsda.plotVar[testable.components]))) +# +# expect_equal(TT, GT) +# }) + + +test_that("(plotVar:basic): mint.pls", { + + testable.components <- Testable.Components$basic.mint.pls + GT <- Ground.Truths$basic.mint.pls + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- stemcells$gene[samples+5, 1:10] + S <- as.character(stemcells$study[samples]) + + res.mint.pls <- mint.pls(X, Y, study = S) + + mint.pls.plotVar = plotVar(res.mint.pls) + + invisible(capture.output(TT <- dput(mint.pls.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): mint.spls", { + + testable.components <- Testable.Components$basic.mint.spls + GT <- Ground.Truths$basic.mint.spls + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- stemcells$gene[samples+5, 1:10] + S <- as.character(stemcells$study[samples]) + + choice.keepX = c(3,3) + choice.keepY = c(3,3) + + res.mint.spls <- mint.spls(X, Y, study = S, keepX = choice.keepX, keepY = choice.keepY) + + mint.spls.plotVar = plotVar(res.mint.spls) + + invisible(capture.output(TT <- dput(mint.spls.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): mint.plsda", { + + testable.components <- Testable.Components$basic.mint.plsda + GT <- Ground.Truths$basic.mint.plsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + res.mint.plsda <- mint.plsda(X, Y, study = S) + + mint.plsda.plotVar = plotVar(res.mint.plsda) + + invisible(capture.output(TT <- dput(mint.plsda.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:basic): mint.splsda", { + + testable.components <- Testable.Components$basic.mint.splsda + GT <- Ground.Truths$basic.mint.splsda + + data(stemcells) + samples <- c(1:5,60:64) + X <- stemcells$gene[samples, 1:10] + Y <- rep(c("hESC", "hiPSC"),5) + S <- as.character(stemcells$study[samples]) + + choice.keepX = c(3,3) + + res.mint.splsda <- mint.splsda(X, Y, study = S, keepX = choice.keepX) + + mint.splsda.plotVar = plotVar(res.mint.splsda) + + invisible(capture.output(TT <- dput(mint.splsda.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(plotVar:parameter): comp", { + + testable.components <- Testable.Components$comp.pca + GT <- Ground.Truths$comp.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X, ncomp=3) + + comp.plotVar = plotVar(res.pca, comp = c(2,3)) + + invisible(capture.output(TT <- dput(comp.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): comp.select", { + + testable.components <- Testable.Components$comp.select.pca + GT <- Ground.Truths$comp.select.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X, ncomp=3) + + comp.select.plotVar = plotVar(res.pca, comp.select = c(2,3)) + + invisible(capture.output(TT <- dput(comp.select.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): blocks", { + + testable.components <- Testable.Components$blocks.block.splsda + GT <- Ground.Truths$blocks.block.splsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX = list(miRNA = c(3,3), + mRNA = c(3,3), + proteomics = c(3,3)) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + blocks.plotVar = plotVar(res.block.splsda, blocks = c("miRNA")) + + invisible(capture.output(TT <- dput(blocks.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): cutoff", { + + testable.components <- Testable.Components$cutoff.pca + GT <- Ground.Truths$cutoff.pca + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X, ncomp=3) + + cutoff.plotVar = plotVar(res.pca, cutoff = 0.5) + + invisible(capture.output(TT <- dput(cutoff.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): col", { + + testable.components <- Testable.Components$col.pls + GT <- Ground.Truths$col.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:5] + Y <- liver.toxicity$clinic[,1:5] + + res.pls <- pls(X, Y) + + col.plotVar = plotVar(res.pls, col = c("purple", "green")) + + invisible(capture.output(TT <- dput(col.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): pch", { + + testable.components <- Testable.Components$pch.pls + GT <- Ground.Truths$pch.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:5] + Y <- liver.toxicity$clinic[,1:5] + + res.pls <- pls(X, Y) + + pch.plotVar = plotVar(res.pls, pch = c(1, 2)) + + invisible(capture.output(TT <- dput(pch.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): cex", { + + testable.components <- Testable.Components$cex.pls + GT <- Ground.Truths$cex.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:5] + Y <- liver.toxicity$clinic[,1:5] + + res.pls <- pls(X, Y) + + cex.plotVar = plotVar(res.pls, cex = c(1, 2)) + + invisible(capture.output(TT <- dput(cex.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(plotVar:parameter): font", { + + testable.components <- Testable.Components$font.pls + GT <- Ground.Truths$font.pls + + data(liver.toxicity) + X <- liver.toxicity$gene[,1:5] + Y <- liver.toxicity$clinic[,1:5] + + res.pls <- pls(X, Y) + + f <- list(X=rep(4,5), + Y=rep(3,5)) + + font.plotVar = plotVar(res.pls, font = f) + + invisible(capture.output(TT <- dput(font.plotVar[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(plotVar:error): catches invalid `style` values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + expect_error(plotVar(res.pca, style = "random.style"), + "'style' must be one of 'ggplot2', '3d' , lattice' or 'graphics'.", + fixed=T) +}) + + +test_that("(plotVar:error): catches invalid `plot`` values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + expect_error(plotVar(res.pca, plot = "random.value"), + "'plot' must be logical.", + fixed=T) +}) + + +test_that("(plotVar:error): catches mismatching `block` names", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + res.block.plsda <- block.plsda(X, Y) + + expect_error(plotVar(res.block.plsda, blocks = "random.block"), + "One element of 'blocks' does not match with the names of the blocks", + fixed=T) +}) + + +test_that("(plotVar:error): a given block has only one component selected", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX = list(miRNA = 3, + mRNA = 3, + proteomics = 3) + + res.block.splsda <- block.splsda(X, Y, ncomp = 1, keepX = choice.keepX) + + expect_error(plotVar(res.block.splsda), + "The number of components for one selected block ' miRNA - mRNA - proteomics ' is 1. The number of components must be superior or equal to 2.", + fixed=T) +}) + + +test_that("(plotVar:error): catches invalid `rad.in` values", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX = list(miRNA = 3, + mRNA = 3, + proteomics = 3) + + res.block.splsda <- block.splsda(X, Y, keepX = choice.keepX) + + expect_error(plotVar(res.block.splsda, rad.in = "random.value"), + "The value taken by 'rad.in' must be between 0 and 1", + fixed=T) + + expect_error(plotVar(res.block.splsda, rad.in = -1), + "The value taken by 'rad.in' must be between 0 and 1", + fixed=T) + + expect_error(plotVar(res.block.splsda, rad.in = 2), + "The value taken by 'rad.in' must be between 0 and 1", + fixed=T) +}) + + +test_that("(plotVar:error): catches invalid `cutoff` values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X) + + expect_error(plotVar(res.pca, cutoff = "random.value"), + "The value taken by 'cutoff' must be between 0 and 1", + fixed=T) + + expect_error(plotVar(res.pca, cutoff = -1), + "The value taken by 'cutoff' must be between 0 and 1", + fixed=T) + + expect_error(plotVar(res.pca, cutoff = 2), + "The value taken by 'cutoff' must be between 0 and 1", + fixed=T) +}) + + +test_that("(plotVar:error): catches invalid `comp` values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X, ncomp = 3) + + expect_error(plotVar(res.pca, comp = c(3,4,5)), + "'comp' must be a numeric vector of length 2.", + fixed=T) + + expect_error(plotVar(res.pca, style = "3d", comp = c(3,4)), + "'comp' must be a numeric vector of length 3.", + fixed=T) + + expect_error(plotVar(res.pca, comp = c(4,5)), + "Each element of 'comp' must be positive <= 3.", + fixed=T) + + expect_error(plotVar(res.pca, comp = c(-1,-2)), + "Each element of 'comp' must be positive <= 3.", + fixed=T) +}) + + +test_that("(plotVar:error): catches invalid `comp.selected` values", { + + data(multidrug) + X <- multidrug$ABC.trans[,1:10] + + res.pca <- pca(X, ncomp = 3) + + expect_error(plotVar(res.pca, comp.select = c(4,5)), + "Each element of 'comp.select' must be positive and <= 3.", + fixed=T) + + expect_error(plotVar(res.pca, comp.select = c(-1,-2)), + "Each element of 'comp.select' must be positive and <= 3.", + fixed=T) +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(plotVar:warning): notifying user of negative correlation between variates of differing blocks", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y = breast.TCGA$data.train$subtype + + choice.keepX = list(miRNA = 3, + mRNA = 3, + proteomics = 3) + + res.block.splsda <- block.splsda(X, Y, ncomp = 3, keepX = choice.keepX) + + # induce negative correlation between variates of differing blocks + res.block.splsda$variates$miRNA[,1] <- -res.block.splsda$variates$mRNA[,1] + + expect_warning(plotVar(res.block.splsda), + "We detected negative correlation between the variates of some blocks, which means that some clusters of variables observed on the correlation circle plot are not necessarily positively correlated.", + fixed=T) +}) + + +############################################################################### + +dev.off() +unlink(list.files(pattern = "*.pdf")) diff --git a/tests/testthat/test-predict.R b/tests/testthat/test-predict.R index bc2cbec1..fd811176 100644 --- a/tests/testthat/test-predict.R +++ b/tests/testthat/test-predict.R @@ -1,98 +1,474 @@ -test_that("predict.mixo_pls works", code = { - data("linnerud") - X <- linnerud$exercise - Y <- linnerud$physiological - linn.pls <- pls(X, Y, ncomp = 2, mode = "classic") + +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-predict.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(predict:basic): pls", { + + testable.components <- Testable.Components$basic.pls + GT <- Ground.Truths$basic.pls + + data(liver.toxicity) + X <- liver.toxicity$gene + Y <- liver.toxicity$clinic + + d <- .minimal_train_test_subset(X, Y, n.tr=6, n.te=3) - indiv1 <- as.integer(colMeans(X)) + 3 - indiv2 <- as.integer(colMeans(X)) - 3 - newdata <- rbind(indiv1, indiv2) - colnames(newdata) <- colnames(X) + res.pls <- pls(d$X.tr, d$Y.tr) - # yhat_approx <- colMeans(Y) + pls.predict = predict(res.pls, d$X.te) - pred <- predict(linn.pls, newdata) - expect_equal(round(pred$predict[1]), round(175.8865 )) - # pred$predict - # yhat_approx + invisible(capture.output(TT <- dput(pls.predict[testable.components]))) + expect_equal(TT, GT) }) -test_that("predict.mixo_plsda works", code = { - data("liver.toxicity") +test_that("(predict:basic): spls", { + + testable.components <- Testable.Components$basic.spls + GT <- Ground.Truths$basic.spls + + data(liver.toxicity) X <- liver.toxicity$gene - Y <- as.factor(liver.toxicity$treatment[, 4]) + Y <- liver.toxicity$clinic + + d <- .minimal_train_test_subset(X, Y, n.tr=6, n.te=3) + + choice.keepX = c(3,3) + choice.keepY = c(3,3) + res.spls <- spls(d$X.tr, d$Y.tr, keepX = choice.keepX, keepY = choice.keepY) - ## if training is perfomed on 4/5th of the original data - samp <- sample(1:5, nrow(X), replace = TRUE) - test <- which(samp == 1) # testing on the first fold - train <- setdiff(1:nrow(X), test) + spls.predict = predict(res.spls, d$X.te) - plsda.train <- plsda(X[train, ], Y[train], ncomp = 2) - test.predict <- predict(plsda.train, X[test, ], dist = "max.dist") - expect_is(test.predict, "predict") + invisible(capture.output(TT <- dput(spls.predict[testable.components]))) + + expect_equal(TT, GT) }) -test_that("predict.block.splsda", code = { - # example with block.splsda=diablo=sgccda and a missing block - data(nutrimouse) - # need to unmap Y for an unsupervised analysis, where Y is included as a data block in data - Y.mat = unmap(nutrimouse$diet) - data = list(gene = nutrimouse$gene, lipid = nutrimouse$lipid, Y = Y.mat) - # with this design, all blocks are connected - design = matrix(c(0,1,1,1,0,1,1,1,0), ncol = 3, nrow = 3, - byrow = TRUE, dimnames = list(names(data), names(data))) - - # train on 75 - ind.train=NULL - for(i in 1:nlevels(nutrimouse$diet)) - ind.train=c(ind.train,which(nutrimouse$diet==levels(nutrimouse$diet)[i])[1:6]) - - #training set - gene.train=nutrimouse$gene[ind.train,] - lipid.train=nutrimouse$lipid[ind.train,] - Y.mat.train=Y.mat[ind.train,] - Y.train=nutrimouse$diet[ind.train] - data.train=list(gene=gene.train,lipid=lipid.train,Y=Y.mat.train) - - #test set - gene.test=nutrimouse$gene[-ind.train,] - lipid.test=nutrimouse$lipid[-ind.train,] - Y.mat.test=Y.mat[-ind.train,] - Y.test=nutrimouse$diet[-ind.train] - data.test=list(gene=gene.test,lipid=lipid.test) - - # example with block.splsda=diablo=sgccda and a missing block - res.train = block.splsda(X=list(gene=gene.train,lipid=lipid.train),Y=Y.train, - ncomp=3,keepX=list(gene=c(10,10,10),lipid=c(5,5,5))) - - expect_warning((test.predict <- predict(res.train, newdata=data.test[2], method = "max.dist"))) - expect_is(test.predict$WeightedPredict, 'array') -}) - - -test_that("predict.mint.splsda works", code = { - ## example with mint.splsda + +test_that("(predict:basic): plsda", { + + testable.components <- Testable.Components$basic.plsda + GT <- Ground.Truths$basic.plsda + + data(srbct) + + X <- srbct$gene[, 1:10] + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + res.plsda <- plsda(d$X.tr, d$Y.tr) + + plsda.predict = predict(res.plsda, d$X.te) + + invisible(capture.output(TT <- dput(plsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): splsda", { + + testable.components <- Testable.Components$basic.splsda + GT <- Ground.Truths$basic.splsda + + data(srbct) + + d <- .minimal_train_test_subset(srbct$gene, srbct$class) + + choice.keepX = c(3,3) + + res.splsda <- splsda(d$X.tr, d$Y.tr, keepX = choice.keepX) + + splsda.predict = predict(res.splsda, d$X.te) + + invisible(capture.output(TT <- dput(splsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): block.pls", { + + testable.components <- Testable.Components$basic.block.pls + GT <- Ground.Truths$basic.block.pls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:5], + mRNA = breast.TCGA$data.train$mrna[,1:5]) + Y <- breast.TCGA$data.train$protein[,1:5] + + d <- .minimal_train_test_subset(X, Y, n.tr=6, n.te=3) + + res.block.pls <- block.pls(d$X.tr, d$Y.tr) + + block.pls.predict = predict(res.block.pls, d$X.te) + + invisible(capture.output(TT <- dput(block.pls.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): block.spls", { + + testable.components <- Testable.Components$basic.block.spls + GT <- Ground.Truths$basic.block.spls + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:5], + mRNA = breast.TCGA$data.train$mrna[,1:5]) + Y <- breast.TCGA$data.train$protein[,1:5] + + d <- .minimal_train_test_subset(X, Y, n.tr=6, n.te=3) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.block.spls <- block.spls(d$X.tr, d$Y.tr, keepX = choice.keepX) + + block.spls.predict = predict(res.block.spls, d$X.te) + + invisible(capture.output(TT <- dput(block.spls.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): block.plsda", { + + testable.components <- Testable.Components$basic.block.plsda + GT <- Ground.Truths$basic.block.plsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10]) + Y = breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + res.block.plsda <- block.plsda(d$X.tr, d$Y.tr) + + block.plsda.predict = predict(res.block.plsda, d$X.te) + + invisible(capture.output(TT <- dput(block.plsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): block.splsda", { + + testable.components <- Testable.Components$basic.block.splsda + GT <- Ground.Truths$basic.block.splsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10]) + Y = breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.block.splsda <- block.splsda(d$X.tr, d$Y.tr, keepX = choice.keepX) + + block.splsda.predict = predict(res.block.splsda, d$X.te) + + invisible(capture.output(TT <- dput(block.splsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): mint.pls", { + + testable.components <- Testable.Components$basic.mint.pls + GT <- Ground.Truths$basic.mint.pls + data(stemcells) + X <- stemcells$gene[, 1:10] + Y <- stemcells$gene[, 11:20] + S <- as.character(stemcells$study) + + d <- .minimal_train_test_subset(X, Y, S=S) + + res.mint.pls <- suppressWarnings(mint.pls(d$X.tr, d$Y.tr, study = d$S.tr)) + + mint.pls.predict = predict(res.mint.pls, d$X.te, d$S.te) + + invisible(capture.output(TT <- dput(mint.pls.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +# test_that("(predict:basic): mint.spls", { +# +# testable.components <- Testable.Components$basic.mint.spls +# GT <- Ground.Truths$basic.mint.spls +# +# data(stemcells) +# X <- stemcells$gene[, 1:10] +# Y <- stemcells$gene[, 11:20] +# S <- as.character(stemcells$study) +# +# d <- .minimal_train_test_subset(X, Y, S=S) +# +# choice.keepX <- c(3,3) +# choice.keepY <- c(3,3) +# +# set.seed(42) +# res.mint.spls <- suppressWarnings(mint.spls(d$X.tr, d$Y.tr, study = d$S.tr, +# keepX = choice.keepX, +# keepY = choice.keepY)) +# +# mint.spls.predict = predict(res.mint.spls, d$X.te, d$S.te) +# +# invisible(capture.output(TT <- dput(mint.spls.predict[testable.components]))) +# +# expect_equal(TT, GT) +# }) + + +test_that("(predict:basic): mint.plsda", { + + testable.components <- Testable.Components$basic.mint.plsda + GT <- Ground.Truths$basic.mint.plsda + + data(stemcells) + X <- stemcells$gene[,1:10] + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S=S) + + res.mint.plsda <- suppressWarnings(mint.plsda(d$X.tr, d$Y.tr, study=d$S.tr)) + + mint.plsda.predict = predict(res.mint.plsda, d$X.te, study=d$S.te) + + invisible(capture.output(TT <- dput(mint.plsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(predict:basic): mint.splsda", { + + testable.components <- Testable.Components$basic.mint.splsda + GT <- Ground.Truths$basic.mint.splsda + + data(stemcells) + X <- stemcells$gene[,1:10] + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S=S) + + choice.keepX <- c(3,3) + + res.mint.splsda <- suppressWarnings(mint.splsda(d$X.tr, d$Y.tr, study=d$S.tr, keepX = choice.keepX)) + + mint.splsda.predict = predict(res.mint.splsda, d$X.te, d$S.te) + + invisible(capture.output(TT <- dput(mint.splsda.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(predict:data): breast.test", { + + testable.components <- Testable.Components$breast.test.block.splsda + GT <- Ground.Truths$breast.test.block.splsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.test$mirna[,1:10], + mRNA = breast.TCGA$data.test$mrna[,1:10]) + Y = breast.TCGA$data.test$subtype + + d <- .minimal_train_test_subset(X, Y) + + choice.keepX <- list(miRNA = c(3,3), + mRNA = c(3,3)) + + res.block.splsda <- block.splsda(d$X.tr, d$Y.tr, keepX = choice.keepX) + + breast.test.predict = predict(res.block.splsda, d$X.te) + + invisible(capture.output(TT <- dput(breast.test.predict[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(predict:parameter): dist", { + + testable.components <- Testable.Components$dist.plsda + GT <- Ground.Truths$dist.plsda + + data(srbct) + + d <- .minimal_train_test_subset(srbct$gene, srbct$class) + + res.plsda <- plsda(d$X.tr, d$Y.tr) + + # ------------------------------------------------------------------------# + # centroids.dist + + centroids.predict = predict(res.plsda, d$X.te, dist = "centroids.dist") + + invisible(capture.output(TT <- dput(centroids.predict[testable.components]))) + expect_equal(TT, GT) + + # ------------------------------------------------------------------------# + # mahalanobis.dist + + mahalanobis.predict = predict(res.plsda, d$X.te, dist = "mahalanobis.dist") + + invisible(capture.output(TT <- dput(mahalanobis.predict[testable.components]))) + expect_equal(TT, GT) +}) + + +# test_that("(predict:parameter): multilevel", { +# +# testable.components <- Testable.Components$multilevel.plsda +# GT <- Ground.Truths$multilevel.plsda +# +# data(vac18) +# X <- vac18$genes[, 1:10] +# Y <- vac18$stimulation +# ML <- vac18$sample +# +# d <- .minimal_train_test_subset(X, Y, ML=ML) +# +# res.plsda <- plsda(d$X.tr, d$Y.tr, multilevel = d$ML.tr) +# +# multilevel.predict = predict(res.plsda, d$X.te, multilevel = d$ML.te) +# +# invisible(capture.output(TT <- dput(multilevel.predict[testable.components]))) +# +# expect_equal(TT, GT) +# +# }) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(predict:error): catches invalid values for 'dist'", { + + data(srbct) + + X <- srbct$gene[, 1:10] + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + res.plsda <- plsda(d$X.tr, d$Y.tr) + + expect_error(predict(res.plsda, d$X.te, dist = "random.dist"), + "ERROR : choose one of the four following modes: 'all', 'max.dist', 'centroids.dist' or 'mahalanobis.dist'", + fixed=T) +}) + + +test_that("(predict:error): catches invalid usage on 'rcgga' objects", { - #training set - ind.test = which(stemcells$study == "3") - gene.train = stemcells$gene[-ind.test,] - Y.train = stemcells$celltype[-ind.test] - study.train = factor(stemcells$study[-ind.test]) + data(nutrimouse) + data = list(gene = nutrimouse$gene, + lipid = nutrimouse$lipid, + Y = unmap(nutrimouse$diet)) + + design = matrix(c(0,1,1, + 1,0,1, + 1,1,0), ncol = 3, nrow = 3, byrow = TRUE) + + + res.rgcca <- wrapper.rgcca(X = data, design = design, tau = c(1, 1, 0), + ncomp = 2, + scheme = "centroid") + + + expect_error(predict(res.rgcca, data), + "no applicable method for 'predict' applied to an object of class \"c('sparse.rgcca', 'rgcca')\"", + fixed=T) +}) + + +test_that("(predict:error): catches invalid values for 'newdata'", { + + data(srbct) + + X <- srbct$gene[, 1:10] + Y <- srbct$class - #test set - gene.test = stemcells$gene[ind.test,] - Y.test = stemcells$celltype[ind.test] - study.test = factor(stemcells$study[ind.test]) + d <- .minimal_train_test_subset(X, Y) - res = mint.splsda(X = gene.train, Y = Y.train, ncomp = 3, keepX = c(10, 5, 15), - study = study.train) + res.plsda <- plsda(d$X.tr, d$Y.tr) - pred = predict(res, newdata = gene.test, study.test = study.test) - # saveRDS(pred, file = 'inst/testdata/predict.mint.splsda.rda') - pred_ref <- readRDS(system.file("testdata", "predict.mint.splsda.rda", package = 'mixOmics')) - expect_equal(pred_ref, pred) + X.te <- data.frame(matrix("val", ncol=ncol(d$X.te), nrow=nrow(d$X.te))) + colnames(X.te) <- colnames(d$X.te) + + expect_error(predict(res.plsda, X.te), + "'X[[1]]' must be a numeric matrix.", + fixed=T) + + d$X.te <- d$X.te[, 1:9] + expect_error(suppressWarnings(predict(res.plsda, d$X.te)), + "'newdata' must include all the variables of 'object$X'", + fixed=T) }) + + +test_that("(predict:error): catches invalid 'newdata' for block objects", { + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10]) + Y = breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + res.block.plsda <- block.plsda(d$X.tr, d$Y.tr) + + expect_error(predict(res.block.plsda, d$X.te[[1]]), + "'newdata' should be a list", + fixed=T) +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### diff --git a/tests/testthat/test-tune.block.splsda.R b/tests/testthat/test-tune.block.splsda.R index ba5a330b..5fdfc68c 100644 --- a/tests/testthat/test-tune.block.splsda.R +++ b/tests/testthat/test-tune.block.splsda.R @@ -1,71 +1,642 @@ -context("tune.block.splsda") - -test_that("tune.block.splsda works with and without parallel without auc", { - - data("breast.TCGA") - data = list( - mrna = breast.TCGA$data.train$mrna, - mirna = breast.TCGA$data.train$mirna, - protein = breast.TCGA$data.train$protein - ) - - design = 'full' - ncomp <- 2 - folds <- 3 - nrep <- 3 - test.keepX = list( - mrna = c(10, 20), - mirna = c(20, 30), - protein = c(3, 6) - ) - - set.seed(100) - subset <- mixOmics:::stratified.subsampling(breast.TCGA$data.train$subtype, folds = 4)[[1]][[1]] - data <- lapply(data, function(omic) omic[subset,]) - Y <- breast.TCGA$data.train$subtype[subset] - - ## -------------------- 1 cpu - set.seed(42) - tune11 = tune.block.splsda( - X = data, - Y = Y, - folds = folds, - ncomp = ncomp, - test.keepX = test.keepX, - design = design, - nrepeat = nrep - ) - expect_is(tune11, "tune.block.splsda") - - # ## -------------------- parallel - # BPPARAM <- if (!.onUnix()) BiocParallel::SnowParam(workers = 2) else BiocParallel::MulticoreParam(workers = 2) - # tune41 = tune.block.splsda( - # X = data, - # Y = Y, - # folds = folds, - # ncomp = ncomp, - # test.keepX = test.keepX, - # design = design, - # nrepeat = nrep, - # BPPARAM = BPPARAM - # ) - # expect_equal(tune11$choice.keepX,tune41$choice.keepX) - - # ## -------------------- already.tested.keepX - # already.tested.X = lapply(tune11$choice.keepX, function(x) { - # x[1] - # }) - - # tune42 = tune.block.splsda( - # X = data, - # Y = Y, - # ncomp = ncomp, - # folds = folds, - # test.keepX = test.keepX, - # design = design, - # already.tested.X = already.tested.X, - # BPPARAM = BPPARAM - # ) - # expect_equal(tune11$choice.keepX,tune42$choice.keepX) + +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + +# parameter +## validation - commented out currently + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-tune.block.splsda.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(tune.block.splsda:basic): basic", { + + testable.components <- Testable.Components$basic.tune.block.splsda + GT <- Ground.Truths$basic.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full"))) + + invisible(capture.output(TT <- dput(block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(tune.block.splsda:data): breast.test", { + + testable.components <- Testable.Components$breast.test.tune.block.splsda + GT <- Ground.Truths$breast.test.tune.block.splsda + + data(breast.TCGA) + X = list(miRNA = breast.TCGA$data.test$mirna[,1:10], + mRNA = breast.TCGA$data.test$mrna[,1:10]) + Y = breast.TCGA$data.test$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9)) + + breast.test.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full"))) + + invisible(capture.output(TT <- dput(breast.test.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +# test_that("(tune.block.splsda:parameter): validation", { +# +# testable.components <- Testable.Components$validation.tune.block.splsda +# GT <- Ground.Truths$validation.tune.block.splsda +# +# data(breast.TCGA) +# X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], +# mRNA = breast.TCGA$data.train$mrna[,1:10], +# proteomics = breast.TCGA$data.train$protein[,1:10]) +# Y <- breast.TCGA$data.train$subtype +# +# d <- .minimal_train_test_subset(X, Y) +# +# test.keepX <- list(miRNA = c(6,9), +# mRNA = c(6,9), +# proteomics = c(6,9)) +# +# breast.test.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, +# test.keepX = test.keepX, +# validation = "loo", design = "full"))) +# +# invisible(capture.output(TT <- dput(breast.test.block.splsda.tune[testable.components]))) +# +# expect_equal(TT, GT) +# }) + + +test_that("(tune.block.splsda:parameter): dist", { + + testable.components <- Testable.Components$dist.tune.block.splsda + GT <- Ground.Truths$dist.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + dist.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design = "full", + dist="centroids.dist"))) + + invisible(capture.output(TT <- dput(dist.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.block.splsda:parameter): measure", { + + testable.components <- Testable.Components$basic.tune.block.splsda + GT <- Ground.Truths$basic.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + measure.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design = "full", + measure="overall"))) + + invisible(capture.output(TT <- dput(measure.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.block.splsda:parameter): BPPARAM", { + + testable.components <- Testable.Components$BPPARAM.tune.block.splsda + GT <- Ground.Truths$BPPARAM.tune.block.splsda + + library(BiocParallel) + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + BPPARAM.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design = "full", + BPPARAM=SnowParam(workers=4)))) + + invisible(capture.output(TT <- dput(BPPARAM.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.block.splsda:parameter): design", { + + testable.components <- Testable.Components$design.tune.block.splsda + GT <- Ground.Truths$design.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + design.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design = 0.1))) + + invisible(capture.output(TT <- dput(design.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.block.splsda:parameter): folds", { + + testable.components <- Testable.Components$folds.tune.block.splsda + GT <- Ground.Truths$folds.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + folds.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 2, design="full"))) + + invisible(capture.output(TT <- dput(folds.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.block.splsda:parameter): near.zero.var", { + + testable.components <- Testable.Components$near.zero.var.tune.block.splsda + GT <- Ground.Truths$near.zero.var.tune.block.splsda + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + X$miRNA[1:145,1:2] <- 0 + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + near.zero.var.block.splsda.tune <- suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design="full", + near.zero.var = T))) + + invisible(capture.output(TT <- dput(near.zero.var.block.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(tune.block.splsda:error): catches invalid use of 'cpus'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + cpus = 4))), + "cpus") +}) + + +test_that("(tune.block.splsda:error): catches invalid 'Y' and 'indY' objects", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + d$Y.tr <- matrix(rnorm(6)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full"))), + "Y") + + d$Y.tr <- factor(rep("LumA", 6)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full"))), + "Y") + + samples <- c(1:2, 50:51, 79:80) + X <- list(miRNA = breast.TCGA$data.train$mirna[samples,1:10], + mRNA = breast.TCGA$data.train$mrna[samples,1:10], + proteomics = breast.TCGA$data.train$protein[samples,1:10], + Y = factor(rep("LumA", 6))) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(X, indY=3, + test.keepX = test.keepX, + folds=3, design = "full"))), + "Y") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(X, indY=4, + test.keepX = test.keepX, + folds=3, design = "full"))), + "Y") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(X, + test.keepX = test.keepX, + folds=3, design = "full"))), + "Y") + + +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'progressBar'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + progressBar = "non-logical"))), + "progressBar") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'ncomp'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + ncomp = -1, + test.keepX = test.keepX, + folds=3, design = "full"))), + "ncomp") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + ncomp = NULL, + test.keepX = test.keepX, + folds=3, design = "full"))), + "ncomp") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + ncomp = "non-numeric", + test.keepX = test.keepX, + folds=3, design = "full"))), + "ncomp") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'validation'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + validation = "random-value"))), + "validation") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + validation = NA))), + "validation") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'measure'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + measure = "random-value"))), + "measure") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'already.tested.X'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + already.tested.X = "random-value"))), + "already.tested.X") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + already.tested.X = NULL))), + "already.tested.X") + + already.tested.X <- list(miRNA = c(6,6), + mRNA = c(9,6), + proteomics = c(6,6)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + already.tested.X = already.tested.X))), + "already.tested.X") + + already.tested.X <- list(miRNA = c(6), + mRNA = c(9,6), + proteomics = c(6,6)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + ncomp=3, + test.keepX = test.keepX, + folds=3, design = "full", + already.tested.X = already.tested.X))), + "already.tested.X") + + already.tested.X <- list(miRNA = list(6,6), + mRNA = c(6,6), + proteomics = c(6,6)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + ncomp=3, + test.keepX = test.keepX, + folds=3, design = "full", + already.tested.X = already.tested.X))), + "already.tested.X") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'test.keepX'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full"))), + "test.keepX") +}) + + +test_that("(tune.block.splsda:error): catches edge cases when utilising 'near.zero.var'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + X$miRNA[1:145,1:2] <- 0 + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_warning(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design="full", + near.zero.var = T)), + "near-zero variance") + + X$miRNA[1:145,1:10] <- 0 + + d <- .minimal_train_test_subset(X, Y) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds = 3, design="full", + near.zero.var = T))), + "No more variables") +}) + + +test_that("(tune.block.splsda:error): catches invalid value of 'folds'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=NULL, design = "full"))), + "folds") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds="random-value", design = "full"))), + "folds") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=1, design = "full"))), + "folds") + + expect_error(suppressWarnings(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=200, design = "full"))), + "folds") +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(tune.block.splsda:warning): catches nrepeat>1 when validation='loo'", { + + data(breast.TCGA) + X <- list(miRNA = breast.TCGA$data.train$mirna[,1:10], + mRNA = breast.TCGA$data.train$mrna[,1:10], + proteomics = breast.TCGA$data.train$protein[,1:10]) + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- list(miRNA = c(6,9), + mRNA = c(6,9), + proteomics = c(6,9)) + expect_warning(suppressMessages(tune.block.splsda(d$X.tr, d$Y.tr, + test.keepX = test.keepX, + folds=3, design = "full", + validation = "loo", + nrepeat=2)), + "validation") }) diff --git a/tests/testthat/test-tune.mint.splsda.R b/tests/testthat/test-tune.mint.splsda.R index 23858a20..8668e5bf 100644 --- a/tests/testthat/test-tune.mint.splsda.R +++ b/tests/testthat/test-tune.mint.splsda.R @@ -1,46 +1,665 @@ -context("tune.mint.splsda") -test_that("tune.mint.splsda works", code = { +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### + + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-tune.mint.splsda.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(tune.mint.splsda:basic): basic", { + + testable.components <- Testable.Components$basic.tune.mint.splsda + GT <- Ground.Truths$basic.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)) + + invisible(capture.output(TT <- dput(mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(tune.mint.splsda:data): breast tcga train", { + + testable.components <- Testable.Components$breast.train.tune.mint.splsda + GT <- Ground.Truths$breast.train.tune.mint.splsda + + data(breast.TCGA) + X <- breast.TCGA$data.train$mrna + Y <- breast.TCGA$data.train$subtype + S <- rep(c(1,2,3), length(Y)/3) + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + breast.train.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)) + + invisible(capture.output(TT <- dput(breast.train.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:data): breast tcga test", { + + testable.components <- Testable.Components$breast.test.tune.mint.splsda + GT <- Ground.Truths$breast.test.tune.mint.splsda + + data(breast.TCGA) + X <- breast.TCGA$data.test$mrna + Y <- breast.TCGA$data.test$subtype + S <- c(rep(c(1,2,3), length(Y)/3), 1) + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + breast.test.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)) + + invisible(capture.output(TT <- dput(breast.test.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(tune.mint.splsda:parameter): ncomp", { + + testable.components <- Testable.Components$ncomp.tune.mint.splsda + GT <- Ground.Truths$ncomp.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + ncomp.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp=4)) + + invisible(capture.output(TT <- dput(ncomp.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): already.tested.X", { + + testable.components <- Testable.Components$already.tested.X.tune.mint.splsda + GT <- Ground.Truths$already.tested.X.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + already.tested.X <- c(15) + + already.tested.X.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp=2, + already.tested.X = already.tested.X)) + + invisible(capture.output(TT <- dput(already.tested.X.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): dist", { + + testable.components <- Testable.Components$dist.tune.mint.splsda + + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + GT <- Ground.Truths$max.dist.tune.mint.splsda + + max.dist.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + dist="max.dist")) + + invisible(capture.output(TT <- dput(max.dist.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) + + # --------- # + + GT <- Ground.Truths$cent.mahal.dist.tune.mint.splsda + + centroids.dist.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + dist="centroids.dist")) + + invisible(capture.output(TT <- dput(centroids.dist.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) + + # --------- # + + mahalanobis.dist.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + dist="mahalanobis.dist")) + + invisible(capture.output(TT <- dput(mahalanobis.dist.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): measure", { + + testable.components <- Testable.Components$measure.tune.mint.splsda + GT <- Ground.Truths$measure.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + measure.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + measure="overall")) + + invisible(capture.output(TT <- dput(measure.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): auc", { + + testable.components <- Testable.Components$auc.tune.mint.splsda + GT <- Ground.Truths$auc.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + auc.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + auc=T)) + + invisible(capture.output(TT <- dput(auc.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): scale", { + + testable.components <- Testable.Components$scale.tune.mint.splsda + GT <- Ground.Truths$scale.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + scale.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + scale=F)) + + invisible(capture.output(TT <- dput(scale.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): tol", { + + testable.components <- Testable.Components$tol.tune.mint.splsda + GT <- Ground.Truths$tol.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + tol.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + tol=0.1)) + + invisible(capture.output(TT <- dput(tol.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): max.iter", { + + testable.components <- Testable.Components$max.iter.tune.mint.splsda + GT <- Ground.Truths$max.iter.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + max.iter.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + max.iter=2)) + + invisible(capture.output(TT <- dput(max.iter.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): near.zero.var", { + + testable.components <- Testable.Components$near.zero.var.tune.mint.splsda + GT <- Ground.Truths$near.zero.var.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + X[1:115,1:390] <- 0 + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + near.zero.var.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + near.zero.var=T)) + + invisible(capture.output(TT <- dput(near.zero.var.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): light.output", { + + testable.components <- Testable.Components$light.output.tune.mint.splsda + GT <- Ground.Truths$light.output.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + light.output.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + light.output=F)) + + invisible(capture.output(TT <- dput(light.output.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.mint.splsda:parameter): signif.threshold", { + + testable.components <- Testable.Components$signif.threshold.tune.mint.splsda + GT <- Ground.Truths$signif.threshold.tune.mint.splsda + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + signif.threshold.mint.splsda.tune <- suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + signif.threshold=1e-12)) + + invisible(capture.output(TT <- dput(signif.threshold.mint.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(tune.mint.splsda:error): catches invalid 'X' objects", { + data(stemcells) - data = stemcells$gene - type.id = stemcells$celltype - exp = stemcells$study + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) - out = tune.mint.splsda( - X = data, - Y = type.id, - ncomp = 2, - near.zero.var = FALSE, - study = exp, - test.keepX = seq(1, 5, 2) - ) + test.keepX <- c(3,6,9) - out$choice.ncomp - out$choice.keepX - expect_is(out, "tune.mint.splsda") - expect_equal(out$choice.ncomp$ncomp, 1) + expect_error(suppressWarnings(tune.mint.splsda(Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "X") + d$X.tr <- as.data.frame(apply(d$X.tr, 2, as.character)) + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "X") }) -test_that("tune.mint.splsda works with custom alpha", code = { + +test_that("(tune.mint.splsda:error): catches invalid 'Y' objects", { + data(stemcells) - data = stemcells$gene - type.id = stemcells$celltype - exp = stemcells$study + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "Y") - out = tune.mint.splsda( - X = data, - Y = type.id, - ncomp = 2, - near.zero.var = FALSE, - study = exp, - test.keepX = seq(1, 5, 2), - signif.threshold = 0.05 - ) + d$Y.tr <- NULL + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "Y") + + d$Y.tr <- d$X.tr[,1:2] + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "Y") + + d$Y.tr <- as.factor(rep("hESC", 12)) + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "Y") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'progressBar' value", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) - out$choice.ncomp - out$choice.keepX - expect_is(out, "tune.mint.splsda") - expect_equal(out$choice.ncomp$ncomp, 1) + test.keepX <- c(3,6,9) + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y = d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + progressBar = "random.value")), + "progressBar") }) + + +test_that("(tune.mint.splsda:error): catches invalid 'ncomp' value", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y = d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp = "random.value")), + "ncomp") + + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y = d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp = NULL)), + "ncomp") + + expect_error(suppressWarnings(tune.mint.splsda(X=d$X.tr, Y = d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp = -1)), + "ncomp") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'already.tested.X' value", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + already.tested.X <- list(15) + expect_error(suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp=2, + already.tested.X = already.tested.X)), + "already.tested.X") + + already.tested.X <- c(15,15) + expect_error(suppressWarnings(tune.mint.splsda(d$X.tr, d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX, + ncomp=2, + already.tested.X = already.tested.X)), + "already.tested.X") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'study' objects", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX)), + "study") + + d$S.tr <- d$S.tr[1:5] + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "study") + + d$S.tr <- as.factor(c(rep(1, 6), rep(2, 5), 3)) + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "study") + + d$S.tr <- as.factor(c(rep(1, 4), rep(2, 4), rep(3, 4))) + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study = d$S.tr, + test.keepX = test.keepX)), + "study") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'light.output' objects", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- c(3,6,9) + + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX, + light.output = "random.value")), + "light.output") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'test.keepX' objects", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S) + + test.keepX <- NULL + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX)), + "test.keepX") + + test.keepX <- c(3) + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX)), + "test.keepX") + + test.keepX <- "c(3,6,9)" + expect_error(suppressWarnings(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX)), + "test.keepX") +}) + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(tune.mint.splsda:warning): warnings for 'study", { + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + S <- stemcells$study + + d <- .minimal_train_test_subset(X, Y, S, n.tr=1) + + test.keepX <- c(3,6,9) + + expect_warning(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX), + "5 samples") + + d$S.tr[12] <- 3 + expect_warning(tune.mint.splsda(X = d$X.tr, Y=d$Y.tr, + study=d$S.tr, + test.keepX = test.keepX), + "all the levels") +}) + + + + + diff --git a/tests/testthat/test-tune.splsda.R b/tests/testthat/test-tune.splsda.R index d01ed6aa..7a6ad9e6 100644 --- a/tests/testthat/test-tune.splsda.R +++ b/tests/testthat/test-tune.splsda.R @@ -1,22 +1,899 @@ -context("tune.splsda") -test_that("tune.splsda works", { - data(breast.tumors) - X = breast.tumors$gene.exp - Y = as.factor(breast.tumors$sample$treatment) - RNGversion(.mixo_rng()) ## in case RNG changes! +############################################################################### +### ============================ MISSING TESTS ============================ ### +############################################################################### - set.seed(100) - tune = tune.splsda(X, Y, ncomp = 2, nrepeat = 3, logratio = "none", - test.keepX = c(5, 10, 15), folds = 3, dist = "max.dist") +# multilevel - currently commented out due to an unknown source of variability + +############################################################################### +### ============================ GROUND TRUTHS ============================ ### +############################################################################### + +Test.Data <- readRDS(system.file("testdata", "testdata-tune.splsda.rda", package = "mixOmics")) +Testable.Components <- Test.Data$tc +Ground.Truths <- Test.Data$gt + +############################################################################### +### ================================ BASIC ================================ ### +############################################################################### + + +test_that("(tune.splsda:basic): basic", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$basic + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2) + + invisible(capture.output(TT <- dput(splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ DATA ================================= ### +############################################################################### + + +test_that("(tune.splsda:data): breast tcga train", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$breast.train + + data(breast.TCGA) + X <- breast.TCGA$data.train$mrna + Y <- breast.TCGA$data.train$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + breast.train.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2) + + invisible(capture.output(TT <- dput(breast.train.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:data): breast tcga test", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$breast.test + + data(breast.TCGA) + X <- breast.TCGA$data.test$mrna + Y <- breast.TCGA$data.test$subtype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + breast.test.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2) + + invisible(capture.output(TT <- dput(breast.test.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:data): stem cells", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$stem.cells + + data(stemcells) + X <- stemcells$gene + Y <- stemcells$celltype + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + stem.cells.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2) + + invisible(capture.output(TT <- dput(stem.cells.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ============================== PARAMETER ============================== ### +############################################################################### + + +test_that("(tune.splsda:parameter): ncomp", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$ncomp + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + ncomp.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + ncomp=3) + + invisible(capture.output(TT <- dput(ncomp.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): test.keepX", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$test.keepX + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- seq(1, 20, 1) + + test.keepX.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2) + + invisible(capture.output(TT <- dput(test.keepX.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): already.tested.X", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$already.tested.X + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + already.tested.X <- c(15) + + already.tested.X.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + already.tested.X = already.tested.X, + ncomp=2) + + invisible(capture.output(TT <- dput(already.tested.X.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): validation", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$validation + + data(srbct) + X <- srbct$gene + Y <- srbct$class - expect_equal(tune$choice.ncomp$ncomp, 1L) - expect_equal(tune$choice.keepX, c(comp1 = 5, comp2 = 15)) + d <- .minimal_train_test_subset(X, Y) + test.keepX <- c(3,6,9) + + validation.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + validation = "loo") + + invisible(capture.output(TT <- dput(validation.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + - set.seed(100) - tune2 = tune.splsda(X, Y, ncomp = 2, nrepeat = 3, logratio = "none", - test.keepX = c(5, 10, 15), folds = 3, dist = "max.dist", cpus = 2) - .almost_identical(tune, tune2) +test_that("(tune.splsda:parameter): dist", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$dist + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y, n.tr=3) + + test.keepX <- c(3,6,9) + + set.seed(16) + centroids.dist.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + dist = "centroids.dist") + + invisible(capture.output(TT <- dput(centroids.dist.splsda.tune[testable.components]))) + + expect_equal(TT, GT) + + set.seed(16) + mahalanobis.dist.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + dist = "mahalanobis.dist") + + invisible(capture.output(TT <- dput(mahalanobis.dist.splsda.tune[testable.components]))) + + expect_equal(TT, GT) }) + + +test_that("(tune.splsda:parameter): measure", { + + testable.components <- Testable.Components$measure + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + set.seed(16) + overall.measure.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + measure="overall") + + invisible(capture.output(TT <- dput(overall.measure.splsda.tune[testable.components]))) + + GT <- Ground.Truths$overall.measure + expect_equal(TT, GT) + + set.seed(16) + auc.measure.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + measure="AUC") + + invisible(capture.output(TT <- dput(auc.measure.splsda.tune[testable.components]))) + + GT <- Ground.Truths$auc.measure + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): scale", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$scale + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + scale.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + scale=F) + + invisible(capture.output(TT <- dput(scale.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): auc", { + + testable.components <- Testable.Components$auc + GT <- Ground.Truths$auc + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + set.seed(16) + auc.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + auc=T, nrepeat = 3) + + invisible(capture.output(TT <- dput(auc.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): progressBar", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$basic + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + progressBar.splsda.tune <- .quiet(tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + progressBar=T)) + + invisible(capture.output(TT <- dput(progressBar.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): tol", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$basic + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + tol.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + tol=1e-12) + + invisible(capture.output(TT <- dput(tol.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): max.iter", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$max.iter + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + max.iter.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + max.iter=2) + + invisible(capture.output(TT <- dput(max.iter.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): near.zero.var", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$nzv.logr + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + X[1:60, 1:2000] <- 0 + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + near.zero.var.splsda.tune <- suppressWarnings(tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + near.zero.var=T)) + + invisible(capture.output(TT <- dput(near.zero.var.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): nrepeat", { + + testable.components <- Testable.Components$nrepeat + GT <- Ground.Truths$nrepeat + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + set.seed(16) + nrepeat.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + nrepeat=10) + + invisible(capture.output(TT <- dput(nrepeat.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): logratio", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$nzv.logr + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + set.seed(16) + logratio.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + logratio="CLR") + + invisible(capture.output(TT <- dput(logratio.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +# test_that("(tune.splsda:parameter): multilevel", { +# +# testable.components <- Testable.Components$basic +# GT <- Ground.Truths$multilevel +# +# data(vac18) +# X <- vac18$genes +# Y <- vac18$stimulation +# ML <- vac18$sample +# +# d <- .minimal_train_test_subset(X, Y, ML=ML, n.tr=4) +# +# test.keepX <- c(3,6,9) +# +# set.seed(16) +# multilevel.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, +# test.keepX = test.keepX, +# folds = 2, +# multilevel=d$ML.tr) +# +# invisible(capture.output(TT <- dput(multilevel.splsda.tune[testable.components]))) +# +# expect_equal(TT, GT) +# }) + + +test_that("(tune.splsda:parameter): light.output", { + + testable.components <- Testable.Components$light.output + GT <- Ground.Truths$light.output + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + light.output.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + light.output=F) + + invisible(capture.output(TT <- dput(light.output.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +test_that("(tune.splsda:parameter): signif.threshold", { + + testable.components <- Testable.Components$basic + GT <- Ground.Truths$basic + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + d <- .minimal_train_test_subset(X, Y) + + test.keepX <- c(3,6,9) + + signif.threshold.splsda.tune <- tune.splsda(X=d$X.tr, Y=d$Y.tr, + test.keepX = test.keepX, + folds = 2, + signif.threshold=1e-12) + + invisible(capture.output(TT <- dput(signif.threshold.splsda.tune[testable.components]))) + + expect_equal(TT, GT) +}) + + +############################################################################### +### ================================ ERROR ================================ ### +############################################################################### + + +test_that("(tune.splsda:error): catches invalid 'X' objects", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(Y=Y, + test.keepX = test.keepX, + folds = 2), + "X") + + X <- as.data.frame(apply(X, 2, as.character)) + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2), + "X") +}) + + +test_that("(tune.splsda:error): catches invalid 'Y' objects", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, + test.keepX = test.keepX, + folds = 2), + "Y") + + expect_error(tune.splsda(X=X, Y=NULL, + test.keepX = test.keepX, + folds = 2), + "Y") + + expect_error(tune.splsda(X=X, Y=X, + test.keepX = test.keepX, + folds = 2), + "Y") + + + expect_error(tune.splsda(X=X, Y=as.factor(rep("EWS", nrow(X))), + test.keepX = test.keepX, + folds = 2), + "Y") +}) + + +test_that("(tune.splsda:error): catches invalid 'multilevel' objects", { + + data(vac18) + X <- vac18$genes + Y <- vac18$stimulation + ML <- vac18$sample + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + multilevel=ML[1:10]), + "multilevel") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + multilevel=cbind(ML, ML)), + "multilevel") + + expect_error(tune.splsda(X=X, Y=cbind(Y,Y,Y), + test.keepX = test.keepX, + folds = 2, + multilevel=ML), + "Y") +}) + + +test_that("(tune.splsda:error): catches invalid 'progressBar' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + progressBar = "random.value"), + "progressBar") +}) + + +test_that("(tune.splsda:error): catches invalid 'ncomp' values", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + ncomp = NULL), + "ncomp") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + ncomp = "random.value"), + "ncomp") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + ncomp = -1), + "ncomp") +}) + + +test_that("(tune.splsda:error): catches invalid 'validation' values", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + validation = "random.value"), + "validation") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'already.tested.X' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + already.tested.X <- list() + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + already.tested.X = already.tested.X), + "already.tested.X") + + already.tested.X <- list(15) + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + already.tested.X = already.tested.X), + "already.tested.X") + + already.tested.X <- c(15,15) + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + ncomp=2, + already.tested.X = already.tested.X), + "already.tested.X") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'measure' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + measure = "random.value"), + "measure") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'folds' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = NULL), + "folds") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 1), + "folds") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 64), + "folds") + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = "random.value"), + "folds") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'validation' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + validation = "random.value"), + "validation") +}) + + +test_that("(tune.mint.splsda:error): catches invalid 'test.keepX' value", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = NULL, + folds = 2), + "test.keepX") + + test.keepX <- c(3,2400, 2500, 2600) + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2), + "test.keepX") +}) + + +test_that("(tune.mint.splsda:error): catches `X` dataframe with non-unique dimnames", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + rownames(X)[1] <- rownames(X)[2] + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2), + "unique") + + + X <- srbct$gene + colnames(X)[1] <- colnames(X)[2] + expect_error(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2), + "Unique") +}) + + +test_that("(tune.mint.splsda:error): catches when all features of 'X' have near zero var", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + X[1:60,] <- 0 + + test.keepX <- c(3,6,9) + + expect_error(suppressWarnings(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + near.zero.var=T)), + "Near Zero Var") +}) + + + + +############################################################################### +### =============================== WARNINGS ============================== ### +############################################################################### + + +test_that("(tune.splsda:warning): catches when 'validation = loo' and 'nrepeat>1", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_warning(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 2, + validation="loo", + nrepeat=2), + "Leave-One-Out") +}) + + +test_that("(tune.splsda:warning): catches when a class isn't represented in a given fold", { + + data(srbct) + X <- srbct$gene + Y <- srbct$class + + test.keepX <- c(3,6,9) + + expect_warning(tune.splsda(X=X, Y=Y, + test.keepX = test.keepX, + folds = 15), + "fold") +}) +