inst/unitTests/test_opls.R
In SamGG/ropls: PCA, PLS(-DA) and OPLS(-DA) for multivariate analysis and feature selection of omics data
test_str <- function() {
data(foods)
strF(foods)
strF(foods, border = 3)
fatML <- matrix(TRUE, nrow = 1, ncol = 1000)
strF(fatML, bigMarkC = "'")
testMC <- matrix("a", nrow = 10, ncol = 10)
strF(testMC)
data(sacurine)
strF(sacurine[["dataMatrix"]])
strF(sacurine[["sampleMetadata"]])
}
test_plot <- function() {
data(sacurine)
for(typeC in c("correlation", "outlier", "overview",
"permutation", "predict-train","predict-test",
"summary", "x-loading", "x-score", "x-variance",
"xy-score", "xy-weight")) {
if(grepl("predict", typeC))
subset <- "odd"
else
subset <- NULL
opLs <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = ifelse(typeC != "xy-weight", 1, 2),
orthoI = ifelse(typeC != "xy-weight", 1, 0),
permI = ifelse(typeC == "permutation", 10, 0),
subset = subset,
printL = FALSE, plotL = FALSE)
plot(opLs, typeVc = typeC)
}
## (O)PLS-DA: Turning display of ellipses off in case parAsColFcVn is numeric
plot(opLs,
parAsColFcVn = sacurine[["sampleMetadata"]][, "age"])
## Converting 'parAsColFcVn' character into a factor (with warning)
plot(opLs,
parAsColFcVn = as.character(sacurine[["sampleMetadata"]][, "gender"]))
}
test_print <- function() {
data(sacurine)
pcaLs <- opls(sacurine[["dataMatrix"]], predI = 2, printL = FALSE, plotL = FALSE)
print(pcaLs)
plsLs <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 2, printL = FALSE, plotL = FALSE)
print(plsLs)
}
test_PCA <- function() {
data(foods) ## contains 3 NA
fooMN <- as.matrix(foods[, colnames(foods) != "Country"])
rownames(fooMN) <- foods[, "Country"]
foo.pca <- opls(fooMN, permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getPcaVarVn(foo.pca)[1],
6.19,
tolerance = 1e-3)
checkEqualsNumeric(getScoreMN(foo.pca)[1, 1],
1.309494,
tolerance = 1e-5)
}
test_PCA_sacurine <- function() {
data(sacurine)
sac.pca <- opls(sacurine[["dataMatrix"]],
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.pca)["Total", "R2X(cum)"],
0.501,
tolerance = 1e-3)
checkEqualsNumeric(sac.pca@modelDF["p3", "R2X"],
0.067,
tolerance = 1e-3)
checkEqualsNumeric(sac.pca@modelDF["p2", "R2X(cum)"],
0.252,
tolerance = 1e-3)
sac.pcaCenter <- opls(sacurine[["dataMatrix"]],
scaleC = "center",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaCenter@modelDF["p2", "R2X(cum)"],
0.223,
tolerance = 1e-3)
sac.pcaPareto <- opls(sacurine[["dataMatrix"]],
scaleC = "pareto",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaPareto@modelDF["p3", "R2X"],
0.063,
tolerance = 1e-3)
sac.pcaSvd <- opls(sacurine[["dataMatrix"]],
algoC = "svd",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaSvd@modelDF["p3", "R2X"],
0.067,
tolerance = 1e-3)
checkEqualsNumeric(getScoreMN(sac.pcaSvd)[1, 1],
-8.744009,
tolerance = 1e-5)
}
test_PLS_single <- function() {
data(cornell) ## see Tenenhaus, 1998
corPlsLs <- opls(as.matrix(cornell[, grep("x", colnames(cornell))]),
matrix(cornell[, "y"], ncol = 1),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getScoreMN(corPlsLs)[1, 1],
2.0513,
tolerance = 1e-3)
cornell.pls <- opls(as.matrix(cornell[, grep("x", colnames(cornell))]),
cornell[, "y"],
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(cornell.pls)[1],
1.125,
tolerance = 1e-3)
}
test_PLS_multiple <- function() {
data(lowarp) ## see Eriksson et al. (2001); presence of NAs
lowarp.pls <- opls(as.matrix(lowarp[, c("glas", "crtp", "mica", "amtp")]),
as.matrix(lowarp[, grepl("^wrp", colnames(lowarp)) |
grepl("^st", colnames(lowarp))]),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(lowarp.pls@weightStarMN[2, 1],
-0.0861,
tolerance = 1e-3)
checkEqualsNumeric(lowarp.pls@uMN["s5", "p2"],
0.596598855,
tolerance = 1e-8)
}
test_PLS_predict_sacurine <- function() {
data(sacurine)
sac.opls <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "age"],
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(predict(sac.opls)[107],
42.97439,
tolerance = 1e-5)
sac.opls <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
pred107Fc <- "M"
names(pred107Fc) <- "HU_125"
pred107Fc <- factor(pred107Fc, levels = c("M", "F"))
checkEquals(predict(sac.opls)[107],
pred107Fc)
trainVi <- 1:floor(nrow(sacurine[["dataMatrix"]]) / 2)
sac.pls.tr <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "age"],
subset = trainVi,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(as.numeric(sac.pls.tr@descriptionMC["samples", 1]),
length(trainVi),
tolerance = 0)
checkEqualsNumeric(predict(sac.pls.tr)[90],
42.94277,
tolerance = 1e-5)
testVi <- setdiff(1:nrow(sacurine[["dataMatrix"]]), trainVi)
predVn <- predict(sac.pls.tr, sacurine[["dataMatrix"]][testVi, ])
checkEqualsNumeric(predVn["HU_207"],
36.38991,
tolerance = 1e-5)
}
test_PLSDA_sacurine <- function() {
data(sacurine)
sac.plsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"], ncol = 1),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsda)["Total", "Q2(cum)"],
0.584,
tolerance = 1e-3)
sac.plsda <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(sac.plsda)[5],
0.7034828,
tolerance = 1e-7)
## splitting the dataset between a reference and a test subsets
sac.plsdaCrv <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
subset = setdiff(1:nrow(sacurine[["dataMatrix"]]), 1:10),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsdaCrv)["Total", "RMSEP"],
0.275,
tolerance = 1e-3)
## for subset = "odd"
## R2X(cum) R2Y(cum) Q2(cum) RMSEE RMSEP pre ort
## h2 0.1802609 0.7666581 0.5618918 0.2446342 0.3422395 2 0
}
test_PLSDA_sacurine_pareto <- function() {
data(sacurine)
sac.plsdaPar <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"], ncol = 1),
scaleC = "pareto",
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsdaPar)["Total", "Q2(cum)"],
0.521,
tolerance = 1e-3)
sac.plsdaPar <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
scaleC = "pareto",
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(sac.plsdaPar)[5],
0.7710519,
tolerance = 1e-7)
}
test_PLSDA_multiclass <- function() {
data(sacurine)
ageVn <- sacurine[["sampleMetadata"]][, "age"]
ageVc <- ifelse(ageVn < 25, "young",
ifelse(ageVn < 40, NA,
ifelse(ageVn < 45, "normal",
ifelse(ageVn < 57, NA,
"old"))))
sacMN <- sacurine[["dataMatrix"]][!is.na(ageVc), ]
ageVc <- ageVc[!is.na(ageVc)]
oplsda.mul <- opls(sacMN, ageVc, predI = 2)
checkEqualsNumeric(getSummaryDF(oplsda.mul)[, "Q2(cum)"],
0.0394,
tolerance = 1e-3)
checkEqualsNumeric(length(getVipVn(oplsda.mul, orthoL = TRUE)),
0,
tolerance = 1e-10)
checkException(opls(sacMN, ageVc, orthoI = NA),
silent = TRUE)
oplsda.mul.par <- opls(sacMN, ageVc,
predI = 2,
scaleC = "pareto")
checkEqualsNumeric(oplsda.mul.par@modelDF["p2", "R2Y(cum)"],
0.442,
tolerance = 1e-3)
checkEqualsNumeric(getSummaryDF(oplsda.mul.par)[, "Q2(cum)"],
0.0531,
tolerance = 1e-3)
}
test_OPLSDA_sacurine <- function() {
data(sacurine)
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"],
ncol = 1),
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getScoreMN(sac.oplsda, orthoL = TRUE)[1, 1],
4.980604,
tolerance = 1e-7)
## R2X(cum) R2Y(cum) Q2(cum) RMSEE pre ort
## sum 0.185 0.668 0.554 0.289 1 1
checkEqualsNumeric(getVipVn(sac.oplsda)[2],
1.551154,
tolerance = 1e-6)
checkEqualsNumeric(getVipVn(sac.oplsda, orthoL = TRUE)[3],
1.642173,
tolerance = 1e-6)
## permutation testing
sac.oplsdaPer <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 1,
orthoI = 1,
permI = 10,
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.oplsdaPer@suppLs[["permMN"]][1, 1],
0.185,
tolerance = 1e-3)
## number of components
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"],
ncol = 1),
predI = 1,
orthoI = NA,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.oplsda)[, "ort"],
2,
tolerance = 1e-3)
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "age"],
ncol = 1),
predI = 1,
orthoI = NA,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.oplsda)[, "ort"],
1,
tolerance = 1e-3)
}
test_OPLSDA_subset <- function() {
## bug fixed following T. Souza remark
tiagoMN <- c(10, 11, 12, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 8, 10, 11, 10, 12, 10, 11, 10, 11, 10, 11, 11, 10, 11, 10, 11, 10, 11, 10, 12, 10, 5, 6, 5, 6, 7, 6, 5, 6, 5, 6, 15, 16, 15, 16, 15, 16, 15, 14, 15, 15, 16, 16, 16, 14, 16, 15, 16, 14, 16, 14, 2, 3, 2, 3, 22, 3, 4, 3, 2, 3, 3, 7, 3, 7, 3, 7, 4, 7, 3, 7, 3, 7, 3, 7, 3, 4, 3, 7, 3, 7, 2, 8, 2, 8, 20, 8, 2, 4, 2, 8, 7, 3, 7, 3, 4, 3, 7, 3, 7, 7, 3, 7, 3, 7, 3, 7, 3, 7, 6, 8, 25, 29, 25, 24, 25, 29, 25, 29, 25, 25, 23, 27, 23, 27, 23, 27, 23, 27, 23, 25, 20, 21, 22, 21, 20, 21, 20, 21, 20, 21)
dim(tiagoMN) <- c(20, 8)
dimnames(tiagoMN) <- list(1:20, letters[1:8])
tiagoFc <- rep(c("P", "F"), each = 10)
opls(tiagoMN, tiagoFc, predI = 1, orthoI = 1, subset = "odd")
oplExc <- opls(tiagoMN, tiagoFc, subset = seq(1, 20, by = 2))
checkException(plot(oplExc, parLabVc = paste0("s", seq(1, 20, by = 2))),
silent = TRUE)
}
test_OPLSDA_ns <- function() {
datMN <- c(76043, 412165, 44943, 27242, 436566, 173175, 242549, 57066, 559869, 3732, 339188, 471368, 262271, 127285, 451270, 212500, 79673, NA, 891129, 43907, 30689, 6877586, 52217, 3158, 10789748, 229568, 4763576, 3878773, 976436, 831937, 608298, 1605075, 72021, 442510, 1107705, 1464339, 31250, 2724553, 72900, 32742, 47259, 544877, 60885, 34582, 529874, 168264, 176500, 76457, 610110, 16262, 279156, 524468, 451573, 591487, 433529, 161069, 214392, 13781, 1580343, 39315, 357351, 1030464, 301983, 67604, 306862, 1028110, 1530493, 270027, 1378535, 289677, 808334, 1132813, 871209, 895435, 715190, 1563158, 784738, 146195, 994336, 239030, 483755, 579287, 1132413, 157113, 1577570, 1469735, 1085454, 477909, 814755, 245417, 610681, 763706, 2406336, 827531, 992508, 569605, 355321, 150259, 1334200, 271010, 2644620, 727587, 1661412, 619181, 136278, 2755434, 593863, 837865, 3526136, 2003278, 1608814, 3446611, 1941527, 113937, 3132404, 2893445, 2092753, 1034666, 1517319, 841661, 250551, 1046138, 456162, 159386, 1013302, 808657, 614370, 250403, 768004, 242085, 504108, 1014041, 1362408, 1057660, 1110050, 566050, 411886, 142233, 1992420, 284775, 560002, 771533, 575790, 392284, 888498, 785428, 645785, 591569, 960658, 910201, 639437, 1092885, 1409045, 2292023, 1246459, 1945577, 710519, 773384, 1061418, 622898, 34236, 58249, 85944, NA, 342102, 129886, 175800, 13154, 230242, NA, 440223, 315368, 10657, 419508, 48673, 28361, 514579, 23108, 867108, 73831, 1252089, 2547452, 905408, 371059, 4983588, 5140022, 2658555, 814523, 2558923, 859466, 4184204, 3865723, 3236644, 2615560, 3820724, 3577833, 2295288, 625924, 7517724, 1341900, 2569205, 26023086, 1604999, 430453, 8103558, 26222916, 257139, 675754, 59906109, 263055, 31151730, 18648127, 14989438, 1554658, 20249262, 5588731, 871010, 15920, 9120781, 44276, 747080, 13420742, 595872, 1172376, 7172632, 3143654, 4059767, 1433702, 5593888, 5402629, 2477288, 3346077, 4230072, 7621236, 8960828, 10335722, 7037373, 1574738, 3359238, 2540044, 374028, 1144386, 539206, 178517, 1046190, 959381, 605191, 310260, 1253319, 477259, 477995, 825691, 1157093, 1089284, 1411802, 1020206, 782673, 346761, 1824553, 387811, 53304, 319783, 280560, 85009, 1333877, 556003, 590779, 209285, 342532, 198512, 569970, 525240, 246282, 1140422, 542345, 1171008, 827723, 222953, 438839, 85554, 368600, 616555, 94936, 622468, 180988, 293988, 352855, 767894, 268331, 167246, 310918, 1248919, 577184, 10985, 335711, 403815, 80614, 63393, 454489, 616061)
dim(datMN) <- c(20, 15)
ageVn <- c(41, 41, 52, 24, 55, 46, 61, 53, 23, 50, 33, 48, 42, 35, 26, 35, 60, 42, 31, 27)
checkException(opls(datMN,
ageVn,
predI = 1,
orthoI = NA,
permI = 0,
printL = FALSE,
plotL = FALSE),
silent = TRUE)
checkException(opls(datMN,
ageVn,
predI = 1,
orthoI = NA,
permI = 0,
scaleC = "pareto",
printL = FALSE,
plotL = FALSE),
silent = TRUE)
}
test_fromW4M <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
}
test_dataMatrix_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEqualsNumeric(exprs(sacSet)["Tryptophan", "HU_020"], 4.594285, tol = 1e-6)
}
test_sampleMetadata_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEqualsNumeric(pData(sacSet)["HU_017", "bmi"], 23.03, tol = 1e-2)
}
test_variableMetadata_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(fData(sacSet)["Taurine", "hmdb"], "HMDB00251")
}
test_sampleNames_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(sampleNames(sacSet)[3], "HU_015")
}
test_variableNames_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(featureNames(sacSet)[5], "X1.3.Dimethyluric.acid")
}
test_multiresponse <- function() {
data(sacurine)
agebmiPls <- opls(sacurine[["dataMatrix"]],
as.matrix(sacurine[["sampleMetadata"]][, c("age","bmi")]))
agebmiPreMN <- predict(agebmiPls)
checkEquals(colnames(agebmiPreMN),
c("age", "bmi"))
checkEqualsNumeric(agebmiPreMN[1, 2], 20.5831139196, tol = 1e-10)
}
SamGG/ropls documentation built on May 29, 2019, 1:51 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
test_str <- function() {
data(foods)
strF(foods)
strF(foods, border = 3)
fatML <- matrix(TRUE, nrow = 1, ncol = 1000)
strF(fatML, bigMarkC = "'")
testMC <- matrix("a", nrow = 10, ncol = 10)
strF(testMC)
data(sacurine)
strF(sacurine[["dataMatrix"]])
strF(sacurine[["sampleMetadata"]])
}
test_plot <- function() {
data(sacurine)
for(typeC in c("correlation", "outlier", "overview",
"permutation", "predict-train","predict-test",
"summary", "x-loading", "x-score", "x-variance",
"xy-score", "xy-weight")) {
if(grepl("predict", typeC))
subset <- "odd"
else
subset <- NULL
opLs <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = ifelse(typeC != "xy-weight", 1, 2),
orthoI = ifelse(typeC != "xy-weight", 1, 0),
permI = ifelse(typeC == "permutation", 10, 0),
subset = subset,
printL = FALSE, plotL = FALSE)
plot(opLs, typeVc = typeC)
}
## (O)PLS-DA: Turning display of ellipses off in case parAsColFcVn is numeric
plot(opLs,
parAsColFcVn = sacurine[["sampleMetadata"]][, "age"])
## Converting 'parAsColFcVn' character into a factor (with warning)
plot(opLs,
parAsColFcVn = as.character(sacurine[["sampleMetadata"]][, "gender"]))
}
test_print <- function() {
data(sacurine)
pcaLs <- opls(sacurine[["dataMatrix"]], predI = 2, printL = FALSE, plotL = FALSE)
print(pcaLs)
plsLs <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 2, printL = FALSE, plotL = FALSE)
print(plsLs)
}
test_PCA <- function() {
data(foods) ## contains 3 NA
fooMN <- as.matrix(foods[, colnames(foods) != "Country"])
rownames(fooMN) <- foods[, "Country"]
foo.pca <- opls(fooMN, permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getPcaVarVn(foo.pca)[1],
6.19,
tolerance = 1e-3)
checkEqualsNumeric(getScoreMN(foo.pca)[1, 1],
1.309494,
tolerance = 1e-5)
}
test_PCA_sacurine <- function() {
data(sacurine)
sac.pca <- opls(sacurine[["dataMatrix"]],
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.pca)["Total", "R2X(cum)"],
0.501,
tolerance = 1e-3)
checkEqualsNumeric(sac.pca@modelDF["p3", "R2X"],
0.067,
tolerance = 1e-3)
checkEqualsNumeric(sac.pca@modelDF["p2", "R2X(cum)"],
0.252,
tolerance = 1e-3)
sac.pcaCenter <- opls(sacurine[["dataMatrix"]],
scaleC = "center",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaCenter@modelDF["p2", "R2X(cum)"],
0.223,
tolerance = 1e-3)
sac.pcaPareto <- opls(sacurine[["dataMatrix"]],
scaleC = "pareto",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaPareto@modelDF["p3", "R2X"],
0.063,
tolerance = 1e-3)
sac.pcaSvd <- opls(sacurine[["dataMatrix"]],
algoC = "svd",
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.pcaSvd@modelDF["p3", "R2X"],
0.067,
tolerance = 1e-3)
checkEqualsNumeric(getScoreMN(sac.pcaSvd)[1, 1],
-8.744009,
tolerance = 1e-5)
}
test_PLS_single <- function() {
data(cornell) ## see Tenenhaus, 1998
corPlsLs <- opls(as.matrix(cornell[, grep("x", colnames(cornell))]),
matrix(cornell[, "y"], ncol = 1),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getScoreMN(corPlsLs)[1, 1],
2.0513,
tolerance = 1e-3)
cornell.pls <- opls(as.matrix(cornell[, grep("x", colnames(cornell))]),
cornell[, "y"],
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(cornell.pls)[1],
1.125,
tolerance = 1e-3)
}
test_PLS_multiple <- function() {
data(lowarp) ## see Eriksson et al. (2001); presence of NAs
lowarp.pls <- opls(as.matrix(lowarp[, c("glas", "crtp", "mica", "amtp")]),
as.matrix(lowarp[, grepl("^wrp", colnames(lowarp)) |
grepl("^st", colnames(lowarp))]),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(lowarp.pls@weightStarMN[2, 1],
-0.0861,
tolerance = 1e-3)
checkEqualsNumeric(lowarp.pls@uMN["s5", "p2"],
0.596598855,
tolerance = 1e-8)
}
test_PLS_predict_sacurine <- function() {
data(sacurine)
sac.opls <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "age"],
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(predict(sac.opls)[107],
42.97439,
tolerance = 1e-5)
sac.opls <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
pred107Fc <- "M"
names(pred107Fc) <- "HU_125"
pred107Fc <- factor(pred107Fc, levels = c("M", "F"))
checkEquals(predict(sac.opls)[107],
pred107Fc)
trainVi <- 1:floor(nrow(sacurine[["dataMatrix"]]) / 2)
sac.pls.tr <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "age"],
subset = trainVi,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(as.numeric(sac.pls.tr@descriptionMC["samples", 1]),
length(trainVi),
tolerance = 0)
checkEqualsNumeric(predict(sac.pls.tr)[90],
42.94277,
tolerance = 1e-5)
testVi <- setdiff(1:nrow(sacurine[["dataMatrix"]]), trainVi)
predVn <- predict(sac.pls.tr, sacurine[["dataMatrix"]][testVi, ])
checkEqualsNumeric(predVn["HU_207"],
36.38991,
tolerance = 1e-5)
}
test_PLSDA_sacurine <- function() {
data(sacurine)
sac.plsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"], ncol = 1),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsda)["Total", "Q2(cum)"],
0.584,
tolerance = 1e-3)
sac.plsda <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(sac.plsda)[5],
0.7034828,
tolerance = 1e-7)
## splitting the dataset between a reference and a test subsets
sac.plsdaCrv <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
subset = setdiff(1:nrow(sacurine[["dataMatrix"]]), 1:10),
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsdaCrv)["Total", "RMSEP"],
0.275,
tolerance = 1e-3)
## for subset = "odd"
## R2X(cum) R2Y(cum) Q2(cum) RMSEE RMSEP pre ort
## h2 0.1802609 0.7666581 0.5618918 0.2446342 0.3422395 2 0
}
test_PLSDA_sacurine_pareto <- function() {
data(sacurine)
sac.plsdaPar <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"], ncol = 1),
scaleC = "pareto",
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.plsdaPar)["Total", "Q2(cum)"],
0.521,
tolerance = 1e-3)
sac.plsdaPar <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
scaleC = "pareto",
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getVipVn(sac.plsdaPar)[5],
0.7710519,
tolerance = 1e-7)
}
test_PLSDA_multiclass <- function() {
data(sacurine)
ageVn <- sacurine[["sampleMetadata"]][, "age"]
ageVc <- ifelse(ageVn < 25, "young",
ifelse(ageVn < 40, NA,
ifelse(ageVn < 45, "normal",
ifelse(ageVn < 57, NA,
"old"))))
sacMN <- sacurine[["dataMatrix"]][!is.na(ageVc), ]
ageVc <- ageVc[!is.na(ageVc)]
oplsda.mul <- opls(sacMN, ageVc, predI = 2)
checkEqualsNumeric(getSummaryDF(oplsda.mul)[, "Q2(cum)"],
0.0394,
tolerance = 1e-3)
checkEqualsNumeric(length(getVipVn(oplsda.mul, orthoL = TRUE)),
0,
tolerance = 1e-10)
checkException(opls(sacMN, ageVc, orthoI = NA),
silent = TRUE)
oplsda.mul.par <- opls(sacMN, ageVc,
predI = 2,
scaleC = "pareto")
checkEqualsNumeric(oplsda.mul.par@modelDF["p2", "R2Y(cum)"],
0.442,
tolerance = 1e-3)
checkEqualsNumeric(getSummaryDF(oplsda.mul.par)[, "Q2(cum)"],
0.0531,
tolerance = 1e-3)
}
test_OPLSDA_sacurine <- function() {
data(sacurine)
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"],
ncol = 1),
predI = 1,
orthoI = 1,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getScoreMN(sac.oplsda, orthoL = TRUE)[1, 1],
4.980604,
tolerance = 1e-7)
## R2X(cum) R2Y(cum) Q2(cum) RMSEE pre ort
## sum 0.185 0.668 0.554 0.289 1 1
checkEqualsNumeric(getVipVn(sac.oplsda)[2],
1.551154,
tolerance = 1e-6)
checkEqualsNumeric(getVipVn(sac.oplsda, orthoL = TRUE)[3],
1.642173,
tolerance = 1e-6)
## permutation testing
sac.oplsdaPer <- opls(sacurine[["dataMatrix"]],
sacurine[["sampleMetadata"]][, "gender"],
predI = 1,
orthoI = 1,
permI = 10,
printL = FALSE, plotL = FALSE)
checkEqualsNumeric(sac.oplsdaPer@suppLs[["permMN"]][1, 1],
0.185,
tolerance = 1e-3)
## number of components
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "gender"],
ncol = 1),
predI = 1,
orthoI = NA,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.oplsda)[, "ort"],
2,
tolerance = 1e-3)
sac.oplsda <- opls(sacurine[["dataMatrix"]],
matrix(sacurine[["sampleMetadata"]][, "age"],
ncol = 1),
predI = 1,
orthoI = NA,
permI = 0, printL = FALSE, plotL = FALSE)
checkEqualsNumeric(getSummaryDF(sac.oplsda)[, "ort"],
1,
tolerance = 1e-3)
}
test_OPLSDA_subset <- function() {
## bug fixed following T. Souza remark
tiagoMN <- c(10, 11, 12, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 11, 10, 8, 10, 11, 10, 12, 10, 11, 10, 11, 10, 11, 11, 10, 11, 10, 11, 10, 11, 10, 12, 10, 5, 6, 5, 6, 7, 6, 5, 6, 5, 6, 15, 16, 15, 16, 15, 16, 15, 14, 15, 15, 16, 16, 16, 14, 16, 15, 16, 14, 16, 14, 2, 3, 2, 3, 22, 3, 4, 3, 2, 3, 3, 7, 3, 7, 3, 7, 4, 7, 3, 7, 3, 7, 3, 7, 3, 4, 3, 7, 3, 7, 2, 8, 2, 8, 20, 8, 2, 4, 2, 8, 7, 3, 7, 3, 4, 3, 7, 3, 7, 7, 3, 7, 3, 7, 3, 7, 3, 7, 6, 8, 25, 29, 25, 24, 25, 29, 25, 29, 25, 25, 23, 27, 23, 27, 23, 27, 23, 27, 23, 25, 20, 21, 22, 21, 20, 21, 20, 21, 20, 21)
dim(tiagoMN) <- c(20, 8)
dimnames(tiagoMN) <- list(1:20, letters[1:8])
tiagoFc <- rep(c("P", "F"), each = 10)
opls(tiagoMN, tiagoFc, predI = 1, orthoI = 1, subset = "odd")
oplExc <- opls(tiagoMN, tiagoFc, subset = seq(1, 20, by = 2))
checkException(plot(oplExc, parLabVc = paste0("s", seq(1, 20, by = 2))),
silent = TRUE)
}
test_OPLSDA_ns <- function() {
datMN <- c(76043, 412165, 44943, 27242, 436566, 173175, 242549, 57066, 559869, 3732, 339188, 471368, 262271, 127285, 451270, 212500, 79673, NA, 891129, 43907, 30689, 6877586, 52217, 3158, 10789748, 229568, 4763576, 3878773, 976436, 831937, 608298, 1605075, 72021, 442510, 1107705, 1464339, 31250, 2724553, 72900, 32742, 47259, 544877, 60885, 34582, 529874, 168264, 176500, 76457, 610110, 16262, 279156, 524468, 451573, 591487, 433529, 161069, 214392, 13781, 1580343, 39315, 357351, 1030464, 301983, 67604, 306862, 1028110, 1530493, 270027, 1378535, 289677, 808334, 1132813, 871209, 895435, 715190, 1563158, 784738, 146195, 994336, 239030, 483755, 579287, 1132413, 157113, 1577570, 1469735, 1085454, 477909, 814755, 245417, 610681, 763706, 2406336, 827531, 992508, 569605, 355321, 150259, 1334200, 271010, 2644620, 727587, 1661412, 619181, 136278, 2755434, 593863, 837865, 3526136, 2003278, 1608814, 3446611, 1941527, 113937, 3132404, 2893445, 2092753, 1034666, 1517319, 841661, 250551, 1046138, 456162, 159386, 1013302, 808657, 614370, 250403, 768004, 242085, 504108, 1014041, 1362408, 1057660, 1110050, 566050, 411886, 142233, 1992420, 284775, 560002, 771533, 575790, 392284, 888498, 785428, 645785, 591569, 960658, 910201, 639437, 1092885, 1409045, 2292023, 1246459, 1945577, 710519, 773384, 1061418, 622898, 34236, 58249, 85944, NA, 342102, 129886, 175800, 13154, 230242, NA, 440223, 315368, 10657, 419508, 48673, 28361, 514579, 23108, 867108, 73831, 1252089, 2547452, 905408, 371059, 4983588, 5140022, 2658555, 814523, 2558923, 859466, 4184204, 3865723, 3236644, 2615560, 3820724, 3577833, 2295288, 625924, 7517724, 1341900, 2569205, 26023086, 1604999, 430453, 8103558, 26222916, 257139, 675754, 59906109, 263055, 31151730, 18648127, 14989438, 1554658, 20249262, 5588731, 871010, 15920, 9120781, 44276, 747080, 13420742, 595872, 1172376, 7172632, 3143654, 4059767, 1433702, 5593888, 5402629, 2477288, 3346077, 4230072, 7621236, 8960828, 10335722, 7037373, 1574738, 3359238, 2540044, 374028, 1144386, 539206, 178517, 1046190, 959381, 605191, 310260, 1253319, 477259, 477995, 825691, 1157093, 1089284, 1411802, 1020206, 782673, 346761, 1824553, 387811, 53304, 319783, 280560, 85009, 1333877, 556003, 590779, 209285, 342532, 198512, 569970, 525240, 246282, 1140422, 542345, 1171008, 827723, 222953, 438839, 85554, 368600, 616555, 94936, 622468, 180988, 293988, 352855, 767894, 268331, 167246, 310918, 1248919, 577184, 10985, 335711, 403815, 80614, 63393, 454489, 616061)
dim(datMN) <- c(20, 15)
ageVn <- c(41, 41, 52, 24, 55, 46, 61, 53, 23, 50, 33, 48, 42, 35, 26, 35, 60, 42, 31, 27)
checkException(opls(datMN,
ageVn,
predI = 1,
orthoI = NA,
permI = 0,
printL = FALSE,
plotL = FALSE),
silent = TRUE)
checkException(opls(datMN,
ageVn,
predI = 1,
orthoI = NA,
permI = 0,
scaleC = "pareto",
printL = FALSE,
plotL = FALSE),
silent = TRUE)
}
test_fromW4M <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
}
test_dataMatrix_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEqualsNumeric(exprs(sacSet)["Tryptophan", "HU_020"], 4.594285, tol = 1e-6)
}
test_sampleMetadata_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEqualsNumeric(pData(sacSet)["HU_017", "bmi"], 23.03, tol = 1e-2)
}
test_variableMetadata_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(fData(sacSet)["Taurine", "hmdb"], "HMDB00251")
}
test_sampleNames_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(sampleNames(sacSet)[3], "HU_015")
}
test_variableNames_get <- function() {
sacSet <- fromW4M(file.path(path.package("ropls"), "extdata"))
library(Biobase)
checkEquals(featureNames(sacSet)[5], "X1.3.Dimethyluric.acid")
}
test_multiresponse <- function() {
data(sacurine)
agebmiPls <- opls(sacurine[["dataMatrix"]],
as.matrix(sacurine[["sampleMetadata"]][, c("age","bmi")]))
agebmiPreMN <- predict(agebmiPls)
checkEquals(colnames(agebmiPreMN),
c("age", "bmi"))
checkEqualsNumeric(agebmiPreMN[1, 2], 20.5831139196, tol = 1e-10)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.