## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>", message = FALSE, warning = FALSE, fig.width = 7, fig.height = 5, dpi = 150 ) # Render as a lightweight source document by default. To rerun the analyses, # render with `options(plsRglm.rebuild_vignette = TRUE)` set beforehand. run_examples <- isTRUE(getOption("plsRglm.rebuild_vignette", FALSE)) has_chemometrics <- requireNamespace("chemometrics", quietly = TRUE) has_xtable <- requireNamespace("xtable", quietly = TRUE) weighted_significance <- function(cv_counts, matind) { counts <- prop.table(cv_counts) row_keys <- paste0("YT", names(counts)) keep <- row_keys %in% rownames(matind) if (!any(keep)) { return(rep(NA_real_, ncol(matind))) } weights <- as.numeric(prop.table(counts[keep])) indicator <- as.matrix(matind[row_keys[keep], , drop = FALSE]) as.numeric(weights %*% indicator) } library(plsRglm) ## ----cornell-cross-validation, eval = run_examples---------------------------- # data(Cornell) # # cv.modpls <- cv.plsR(Y ~ ., data = Cornell, nt = 6, K = 6) # res.cv.modpls <- cvtable(summary(cv.modpls)) # # res6 <- plsR(Y ~ ., data = Cornell, nt = 6, typeVC = "standard", pvals.expli = TRUE) # colSums(res6$pvalstep) # res6$InfCrit # # res6 <- plsR(Y ~ ., data = Cornell, nt = 6, pvals.expli = TRUE) # colSums(res6$pvalstep) ## ----cornell-cross-validation-repeat, eval = run_examples--------------------- # set.seed(123) # cv.modpls <- cv.plsR( # Y ~ ., # data = Cornell, # nt = 6, # K = 6, # NK = 100, # random = TRUE, # verbose = FALSE # ) # res.cv.modpls <- cvtable(summary(cv.modpls)) # plot(res.cv.modpls) ## ----cornell-model, eval = run_examples--------------------------------------- # res <- plsR(Y ~ ., data = Cornell, nt = 1, pvals.expli = TRUE) # res # res$wwetoile # biplot(res6$tt, res6$pp) # # modpls2 <- plsR(Y ~ ., data = Cornell, 6, sparse = TRUE) # modpls3 <- plsR(Y ~ ., data = Cornell, 6, sparse = TRUE, sparseStop = FALSE) ## ----cornell-bootstrap-yx, eval = run_examples-------------------------------- # set.seed(123) # Cornell.bootYX1 <- bootpls(res, R = 1000, verbose = FALSE) # # boxplots.bootpls(Cornell.bootYX1, indice = 2:8) # temp.ci <- confints.bootpls(Cornell.bootYX1, indice = 2:8) # plots.confints.bootpls( # temp.ci, # typeIC = "BCa", # colIC = c("blue", "blue", "blue", "blue"), # legendpos = "topright" # ) # # plot(Cornell.bootYX1, index = 2, jack = TRUE) # car::dataEllipse( # Cornell.bootYX1$t[, 2], # Cornell.bootYX1$t[, 3], # cex = 0.3, # levels = c(0.5, 0.95, 0.99), # robust = TRUE, # xlab = "X2", # ylab = "X3" # ) ## ----cornell-bootstrap-yt, eval = run_examples-------------------------------- # set.seed(123) # Cornell.bootYT1 <- bootpls(res, typeboot = "fmodel_np", R = 1000) # boxplots.bootpls(Cornell.bootYT1, indices = 2:8) # # temp.ci <- confints.bootpls(Cornell.bootYT1, indices = 2:8) # plots.confints.bootpls( # temp.ci, # typeIC = "BCa", # colIC = c("blue", "blue", "blue", "blue"), # legendpos = "topright" # ) # # res2 <- plsR(Y ~ ., data = Cornell, nt = 2) # Cornell.bootYT2 <- bootpls(res2, typeboot = "fmodel_np", R = 1000) # temp.ci2 <- confints.bootpls(Cornell.bootYT2, indices = 2:8) # # ind.BCa.CornellYT1 <- (temp.ci[, 7] < 0 & temp.ci[, 8] < 0) | (temp.ci[, 7] > 0 & temp.ci[, 8] > 0) # ind.BCa.CornellYT2 <- (temp.ci2[, 7] < 0 & temp.ci2[, 8] < 0) | (temp.ci2[, 7] > 0 & temp.ci2[, 8] > 0) # # matind <- rbind(YT1 = ind.BCa.CornellYT1, YT2 = ind.BCa.CornellYT2) # pi.e <- prop.table(res.cv.modpls$CVQ2)[-1] %*% matind # # signpred(t(matind), labsize = 0.5, plotsize = 12) # text(1:(ncol(matind)) - 0.5, -0.5, pi.e, cex = 1.4) # mtext(expression(pi[e]), side = 2, las = 1, line = 2, at = -0.5, cex = 1.4) ## ----microsat-original-data, eval = run_examples------------------------------ # data(aze) # Xaze <- aze[, 2:34] # yaze <- aze$y ## ----microsat-original-cross-validation, eval = run_examples------------------ # cv.modpls <- cv.plsRglm( # object = yaze, # dataX = Xaze, # nt = 10, # modele = "pls-glm-logistic", # K = 8 # ) # res.cv.modpls <- cvtable(summary(cv.modpls, MClassed = TRUE)) # # res10 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-logistic", pvals.expli = TRUE) # colSums(res10$pvalstep) # # modpls2 <- plsRglm( # dataY = yaze, # dataX = Xaze, # nt = 10, # modele = "pls-glm-logistic", # sparse = TRUE, # sparseStop = TRUE # ) # # set.seed(123) # cv.modpls.logit <- cv.plsRglm( # object = yaze, # dataX = Xaze, # nt = 10, # modele = "pls-glm-logistic", # K = 8, # NK = 100 # ) # res.cv.modpls.logit <- cvtable(summary(cv.modpls.logit, MClassed = TRUE)) # plot(res.cv.modpls.logit) ## ----microsat-original-model, eval = run_examples----------------------------- # res <- plsRglm(yaze, Xaze, nt = 4, modele = "pls-glm-logistic", pvals.expli = TRUE) # res # res$wwetoile # biplot(res$tt, res$pp) # # modpls3 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-logistic", sparse = FALSE, pvals.expli = TRUE) # modpls4 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-logistic", sparse = TRUE, pvals.expli = TRUE) ## ----microsat-original-bootstrap-yx, eval = run_examples---------------------- # set.seed(123) # aze.bootYX4 <- bootplsglm(res, typeboot = "plsmodel", R = 1000, verbose = FALSE) # # boxplots.bootpls(aze.bootYX4, las = 2, mar = c(5, 2, 1, 1) + 0.1) # temp.ci <- confints.bootpls(aze.bootYX4) # plots.confints.bootpls( # temp.ci, # typeIC = "BCa", # colIC = c("blue", "blue", "blue", "blue"), # legendpos = "topright", # las = 2, # mar = c(5, 2, 1, 1) + 0.1 # ) ## ----microsat-original-bootstrap-yt, eval = run_examples---------------------- # set.seed(123) # aze.bootYT4 <- bootplsglm(res, R = 1000, verbose = FALSE) # # boxplots.bootpls(aze.bootYT4, las = 2, mar = c(5, 2, 1, 1) + 0.1) # temp.ci4 <- confints.bootpls(aze.bootYT4) # plots.confints.bootpls( # temp.ci4, # typeIC = "BCa", # colIC = c("blue", "blue", "blue", "blue"), # legendpos = "topright", # las = 2, # mar = c(5, 2, 1, 1) + 0.1 # ) # # res1 <- plsRglm(yaze, Xaze, nt = 1, modele = "pls-glm-logistic") # res2 <- plsRglm(yaze, Xaze, nt = 2, modele = "pls-glm-logistic") # res3 <- plsRglm(yaze, Xaze, nt = 3, modele = "pls-glm-logistic") # res5 <- plsRglm(yaze, Xaze, nt = 5, modele = "pls-glm-logistic") # res6 <- plsRglm(yaze, Xaze, nt = 6, modele = "pls-glm-logistic") # res7 <- plsRglm(yaze, Xaze, nt = 7, modele = "pls-glm-logistic") # res8 <- plsRglm(yaze, Xaze, nt = 8, modele = "pls-glm-logistic") # # aze.bootYT1 <- bootplsglm(res1, R = 1000) # aze.bootYT2 <- bootplsglm(res2, R = 1000) # aze.bootYT3 <- bootplsglm(res3, R = 1000) # aze.bootYT5 <- bootplsglm(res5, R = 1000) # aze.bootYT6 <- bootplsglm(res6, R = 1000) # aze.bootYT7 <- bootplsglm(res7, R = 1000) # aze.bootYT8 <- bootplsglm(res8, R = 1000) # # temp.ci1 <- confints.bootpls(aze.bootYT1) # temp.ci2 <- confints.bootpls(aze.bootYT2) # temp.ci3 <- confints.bootpls(aze.bootYT3) # temp.ci5 <- confints.bootpls(aze.bootYT5) # temp.ci6 <- confints.bootpls(aze.bootYT6) # temp.ci7 <- confints.bootpls(aze.bootYT7) # temp.ci8 <- confints.bootpls(aze.bootYT8) # # ind.BCa.azeYT1 <- (temp.ci1[, 7] < 0 & temp.ci1[, 8] < 0) | (temp.ci1[, 7] > 0 & temp.ci1[, 8] > 0) # ind.BCa.azeYT2 <- (temp.ci2[, 7] < 0 & temp.ci2[, 8] < 0) | (temp.ci2[, 7] > 0 & temp.ci2[, 8] > 0) # ind.BCa.azeYT3 <- (temp.ci3[, 7] < 0 & temp.ci3[, 8] < 0) | (temp.ci3[, 7] > 0 & temp.ci3[, 8] > 0) # ind.BCa.azeYT4 <- (temp.ci4[, 7] < 0 & temp.ci4[, 8] < 0) | (temp.ci4[, 7] > 0 & temp.ci4[, 8] > 0) # ind.BCa.azeYT5 <- (temp.ci5[, 7] < 0 & temp.ci5[, 8] < 0) | (temp.ci5[, 7] > 0 & temp.ci5[, 8] > 0) # ind.BCa.azeYT6 <- (temp.ci6[, 7] < 0 & temp.ci6[, 8] < 0) | (temp.ci6[, 7] > 0 & temp.ci6[, 8] > 0) # ind.BCa.azeYT7 <- (temp.ci7[, 7] < 0 & temp.ci7[, 8] < 0) | (temp.ci7[, 7] > 0 & temp.ci7[, 8] > 0) # ind.BCa.azeYT8 <- (temp.ci8[, 7] < 0 & temp.ci8[, 8] < 0) | (temp.ci8[, 7] > 0 & temp.ci8[, 8] > 0) # # matind <- rbind( # YT1 = ind.BCa.azeYT1, # YT2 = ind.BCa.azeYT2, # YT3 = ind.BCa.azeYT3, # YT4 = ind.BCa.azeYT4, # YT5 = ind.BCa.azeYT5, # YT6 = ind.BCa.azeYT6, # YT7 = ind.BCa.azeYT7, # YT8 = ind.BCa.azeYT8 # ) # # pi.e <- weighted_significance(res.cv.modpls.logit$CVMC, matind) # signpred(t(matind), labsize = 2, plotsize = 12) # text(1:(ncol(matind)) - 0.5, -1, pi.e, cex = 0.5) # mtext(expression(pi[e]), side = 2, las = 1, line = 2, at = -1) ## ----microsat-link-options, eval = run_examples------------------------------- # modpls <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-logistic", MClassed = TRUE, pvals.expli = TRUE) # modpls2 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "logit"), MClassed = TRUE, pvals.expli = TRUE) # modpls3 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "probit"), MClassed = TRUE, pvals.expli = TRUE) # modpls4 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "cauchit"), MClassed = TRUE, pvals.expli = TRUE) # modpls5 <- plsRglm(yaze, Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "cloglog"), MClassed = TRUE, pvals.expli = TRUE) # # set.seed(123) # cv.modpls.probit <- cv.plsRglm(object = yaze, dataX = Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "probit"), K = 8, NK = 100) # cv.modpls.cauchit <- cv.plsRglm(object = yaze, dataX = Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "cauchit"), K = 8, NK = 100) # cv.modpls.cloglog <- cv.plsRglm(object = yaze, dataX = Xaze, nt = 10, modele = "pls-glm-family", family = binomial(link = "cloglog"), K = 8, NK = 100) # # res.cv.modpls.probit <- cvtable(summary(cv.modpls.probit, MClassed = TRUE)) # res.cv.modpls.cauchit <- cvtable(summary(cv.modpls.cauchit, MClassed = TRUE)) # # layout(matrix(1:4, nrow = 2)) # plot(res.cv.modpls.logit) # plot(res.cv.modpls.probit) # plot(res.cv.modpls.cauchit) # layout(1) ## ----microsat-imputed, eval = run_examples------------------------------------ # data(aze_compl) # Xaze_compl <- aze_compl[, 2:34] # yaze_compl <- aze_compl$y # # cv.modpls_compl <- cv.plsRglm( # object = yaze_compl, # dataX = Xaze_compl, # nt = 10, # modele = "pls-glm-logistic", # K = 8 # ) # res.cv.modpls_compl <- cvtable(summary(cv.modpls_compl, MClassed = TRUE)) # # set.seed(123) # cv.modpls_compl <- cv.plsRglm( # object = yaze_compl, # dataX = Xaze_compl, # nt = 10, # modele = "pls-glm-logistic", # K = 8, # NK = 100 # ) # res.cv.modpls_compl <- cvtable(summary(cv.modpls_compl, MClassed = TRUE)) # plot(res.cv.modpls_compl) # # res_compl <- plsRglm(yaze_compl, Xaze_compl, nt = 3, modele = "pls-glm-logistic", pvals.expli = TRUE) # res_compl # # aze_compl.bootYX3 <- bootplsglm(res_compl, typeboot = "plsmodel", R = 1000, verbose = FALSE) # boxplots.bootpls(aze_compl.bootYX3, las = 2, mar = c(5, 2, 1, 1) + 0.1) # temp.ci <- confints.bootpls(aze_compl.bootYX3) # plots.confints.bootpls(temp.ci, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright", las = 2, mar = c(5, 2, 1, 1) + 0.1) # # aze_compl.bootYT3 <- bootplsglm(res_compl, R = 1000, verbose = FALSE) # boxplots.bootpls(aze_compl.bootYT3, las = 2, mar = c(5, 2, 1, 1) + 0.1) # temp.ci3 <- confints.bootpls(aze_compl.bootYT3) # plots.confints.bootpls(temp.ci3, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright", las = 2, mar = c(5, 2, 1, 1) + 0.1) ## ----pine-cross-validation, eval = run_examples------------------------------- # data(pine) # Xpine <- pine[, 1:10] # ypine <- pine[, 11] # # cv.modpls <- cv.plsR(ypine, Xpine, nt = 10) # res.cv.modpls <- cvtable(summary(cv.modpls)) # # res1 <- plsR(ypine, Xpine, nt = 10, typeVC = "standard", pvals.expli = TRUE) # colSums(res1$pvalstep) # res1$InfCrit # # set.seed(123) # cv.modpls <- cv.plsR(x11 ~ ., data = pine, nt = 10, NK = 100) # res.cv.modpls <- cvtable(summary(cv.modpls)) # plot(res.cv.modpls) ## ----pine-models, eval = run_examples----------------------------------------- # res <- plsR(x11 ~ ., data = pine, nt = 1, pvals.expli = TRUE) # res # biplot(res1$tt, res1$pp) # # data(pine_full) # Xpine_full <- pine_full[, 1:10] # ypine_full <- pine_full[, 11] # modpls5 <- plsR(log(ypine_full), Xpine_full, 1) # # XpineNAX21 <- Xpine # XpineNAX21[1, 2] <- NA # modpls6 <- plsR(ypine, XpineNAX21, 4) # modpls6$YChapeau[1, ] # plsR(ypine, XpineNAX21, 2, dataPredictY = XpineNAX21[1, ])$ValsPredictY # # modpls7 <- plsR(ypine, XpineNAX21, 4, EstimXNA = TRUE) # modpls7$XChapeau # modpls7$XChapeauNA # # plsR(ypine, Xpine, 10, typeVC = "none")$InfCrit # plsR(ypine, Xpine, 10, typeVC = "standard")$InfCrit # plsR(ypine, Xpine, 10, typeVC = "adaptative")$InfCrit # plsR(ypine, Xpine, 10, typeVC = "missingdata")$InfCrit # plsR(ypine, XpineNAX21, 10, typeVC = "none")$InfCrit # plsR(ypine, XpineNAX21, 10, typeVC = "standard")$InfCrit # plsR(ypine, XpineNAX21, 10, typeVC = "adaptative")$InfCrit # plsR(ypine, XpineNAX21, 10, typeVC = "missingdata")$InfCrit ## ----pine-bootstrap, eval = run_examples-------------------------------------- # set.seed(123) # Pine.bootYX1 <- bootpls(res, R = 1000) # boxplots.bootpls(Pine.bootYX1, indice = 2:11) # temp.ci <- confints.bootpls(Pine.bootYX1, indice = 2:11) # plots.confints.bootpls(temp.ci, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") # plot(Pine.bootYX1, index = 2, jack = TRUE) # car::dataEllipse(Pine.bootYX1$t[, 2], Pine.bootYX1$t[, 3], cex = 0.3, levels = c(0.5, 0.95, 0.99), robust = TRUE, xlab = "X2", ylab = "X3") # # set.seed(123) # Pine.bootYT1 <- bootpls(res, typeboot = "fmodel_np", R = 1000) # boxplots.bootpls(Pine.bootYT1, indices = 2:11) # temp.ci <- confints.bootpls(Pine.bootYT1, indices = 2:11) # plots.confints.bootpls(temp.ci, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") ## ----bordeaux-cross-validation, eval = run_examples--------------------------- # set.seed(12345) # data(bordeaux) # bordeaux$Quality <- factor(bordeaux$Quality, ordered = TRUE) # # modpls1 <- plsRglm(Quality ~ ., data = bordeaux, 4, modele = "pls-glm-polr", pvals.expli = TRUE) # modpls1 # # Xbordeaux <- bordeaux[, 1:4] # ybordeaux <- bordeaux$Quality # modpls2 <- plsRglm(ybordeaux, Xbordeaux, 4, modele = "pls-glm-polr", pvals.expli = TRUE) # modpls2 # # all(modpls1$InfCrit == modpls2$InfCrit) # colSums(modpls2$pvalstep) # # set.seed(123) # cv.modpls <- cv.plsRglm(ybordeaux, Xbordeaux, nt = 4, modele = "pls-glm-polr", NK = 100, verbose = FALSE) # res.cv.modpls <- cvtable(summary(cv.modpls, MClassed = TRUE)) # plot(res.cv.modpls) # # res <- plsRglm(ybordeaux, Xbordeaux, 1, modele = "pls-glm-polr") # res$FinalModel # biplot(modpls1$tt, modpls1$pp) # # XbordeauxNA <- Xbordeaux # XbordeauxNA[1, 1] <- NA # modplsNA <- plsRglm(ybordeaux, XbordeauxNA, 4, modele = "pls-glm-polr") # modplsNA # data.frame(formula = modpls1$Coeffs, datasets = modpls2$Coeffs, datasetsNA = modplsNA$Coeffs) ## ----bordeaux-bootstrap-yx, eval = run_examples------------------------------- # options(contrasts = c("contr.treatment", "contr.poly")) # # modplsglm3 <- plsRglm(ybordeaux, Xbordeaux, 1, modele = "pls-glm-polr") # bordeaux.bootYT <- bootplsglm(modplsglm3, sim = "permutation", R = 250, verbose = FALSE) # boxplots.bootpls(bordeaux.bootYT) # boxplots.bootpls(bordeaux.bootYT, ranget0 = TRUE) # # bordeaux.bootYX1 <- bootplsglm(res, typeboot = "plsmodel", sim = "balanced", R = 1000, verbose = FALSE) # boxplots.bootpls(bordeaux.bootYX1) # temp.ci <- confints.bootpls(bordeaux.bootYX1) # plots.confints.bootpls(temp.ci, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") # # bordeaux.bootYX1strata <- bootplsglm(res, typeboot = "plsmodel", sim = "balanced", R = 1000, strata = unclass(ybordeaux), verbose = FALSE) # boxplots.bootpls(bordeaux.bootYX1strata) # confints.bootpls(bordeaux.bootYX1strata) # plots.confints.bootpls(confints.bootpls(bordeaux.bootYX1strata), typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") ## ----bordeaux-bootstrap-yt, eval = run_examples------------------------------- # bordeaux.bootYT1 <- bootplsglm(res, sim = "balanced", R = 1000, verbose = FALSE) # boxplots.bootpls(bordeaux.bootYT1) # temp.ci <- confints.bootpls(bordeaux.bootYT1) # plots.confints.bootpls(temp.ci, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") # # bordeaux.bootYT1strata <- bootplsglm(res, sim = "balanced", R = 1000, strata = unclass(ybordeaux), verbose = FALSE) # boxplots.bootpls(bordeaux.bootYT1strata) # temp.cis <- confints.bootpls(bordeaux.bootYT1strata) # plots.confints.bootpls(temp.cis, typeIC = "BCa", colIC = c("blue", "blue", "blue", "blue"), legendpos = "topright") # # res2 <- plsRglm(ybordeaux, Xbordeaux, 2, modele = "pls-glm-polr", verbose = FALSE) # res3 <- plsRglm(ybordeaux, Xbordeaux, 3, modele = "pls-glm-polr", verbose = FALSE) # res4 <- plsRglm(ybordeaux, Xbordeaux, 4, modele = "pls-glm-polr", verbose = FALSE) # # bordeaux.bootYT2 <- bootplsglm(res2, sim = "balanced", R = 1000, verbose = FALSE) # bordeaux.bootYT3 <- bootplsglm(res3, sim = "balanced", R = 1000, verbose = FALSE) # bordeaux.bootYT4 <- bootplsglm(res4, sim = "balanced", R = 1000, verbose = FALSE) # bordeaux.bootYT2s <- bootplsglm(res2, sim = "balanced", R = 1000, strata = unclass(ybordeaux), verbose = FALSE) # bordeaux.bootYT3s <- bootplsglm(res3, sim = "balanced", R = 1000, strata = unclass(ybordeaux), verbose = FALSE) # bordeaux.bootYT4s <- bootplsglm(res4, sim = "balanced", R = 1000, strata = unclass(ybordeaux), verbose = FALSE) # # temp.ci2 <- confints.bootpls(bordeaux.bootYT2) # temp.ci3 <- confints.bootpls(bordeaux.bootYT3) # temp.ci4 <- confints.bootpls(bordeaux.bootYT4) # temp.cis2 <- confints.bootpls(bordeaux.bootYT2s) # temp.cis3 <- confints.bootpls(bordeaux.bootYT3s) # temp.cis4 <- confints.bootpls(bordeaux.bootYT4s) # # ind.BCa.bordeauxYT1 <- (temp.ci[, 7] < 0 & temp.ci[, 8] < 0) | (temp.ci[, 7] > 0 & temp.ci[, 8] > 0) # ind.BCa.bordeauxYT2 <- (temp.ci2[, 7] < 0 & temp.ci2[, 8] < 0) | (temp.ci2[, 7] > 0 & temp.ci2[, 8] > 0) # ind.BCa.bordeauxYT3 <- (temp.ci3[, 7] < 0 & temp.ci3[, 8] < 0) | (temp.ci3[, 7] > 0 & temp.ci3[, 8] > 0) # ind.BCa.bordeauxYT4 <- (temp.ci4[, 7] < 0 & temp.ci4[, 8] < 0) | (temp.ci4[, 7] > 0 & temp.ci4[, 8] > 0) # ind.BCa.bordeauxYT1s <- (temp.cis[, 7] < 0 & temp.cis[, 8] < 0) | (temp.cis[, 7] > 0 & temp.cis[, 8] > 0) # ind.BCa.bordeauxYT2s <- (temp.cis2[, 7] < 0 & temp.cis2[, 8] < 0) | (temp.cis2[, 7] > 0 & temp.cis2[, 8] > 0) # ind.BCa.bordeauxYT3s <- (temp.cis3[, 7] < 0 & temp.cis3[, 8] < 0) | (temp.cis3[, 7] > 0 & temp.cis3[, 8] > 0) # ind.BCa.bordeauxYT4s <- (temp.cis4[, 7] < 0 & temp.cis4[, 8] < 0) | (temp.cis4[, 7] > 0 & temp.cis4[, 8] > 0) # # matind <- rbind(YT1 = ind.BCa.bordeauxYT1, YT2 = ind.BCa.bordeauxYT2, YT3 = ind.BCa.bordeauxYT3, YT4 = ind.BCa.bordeauxYT4) # pi.e <- weighted_significance(res.cv.modpls$CVMC, matind) # signpred(t(matind), labsize = 0.5, plotsize = 12) # mtext(expression(pi[e]), side = 2, las = 1, line = 2, at = -0.3, cex = 1.4) # text(1:(ncol(matind)) - 0.5, -0.3, pi.e, cex = 1.4) # text(1:(ncol(matind)) - 0.5, -0.75, c("Temp", "Sun", "Heat", "Rain"), cex = 1.4) # # matinds <- rbind(YT1 = ind.BCa.bordeauxYT1s, YT2 = ind.BCa.bordeauxYT2s, YT3 = ind.BCa.bordeauxYT3s, YT4 = ind.BCa.bordeauxYT4s) # pi.es <- weighted_significance(res.cv.modpls$CVMC, matinds) # signpred(t(matinds), pred.lablength = 10, labsize = 0.5, plotsize = 12) # mtext(expression(pi[e]), side = 2, las = 1, line = 2, at = -0.3, cex = 1.4) # text(1:(ncol(matinds)) - 0.5, -0.3, pi.es, cex = 1.4) # text(1:(ncol(matinds)) - 0.5, -0.75, c("Temp", "Sun", "Heat", "Rain"), cex = 1.4) ## ----hyptis-analysis, eval = run_examples && has_chemometrics----------------- # data("hyptis", package = "chemometrics") # yhyptis <- factor(hyptis$Group, ordered = TRUE) # Xhyptis <- as.data.frame(hyptis[, 1:6]) # # modpls <- plsRglm(yhyptis, Xhyptis, 6, modele = "pls-glm-polr", pvals.expli = TRUE) # modpls # colSums(modpls$pvalstep) # # set.seed(123) # cv.modpls <- cv.plsRglm(object = yhyptis, dataX = Xhyptis, nt = 4, K = 5, NK = 100, modele = "pls-glm-polr") # res.cv.modpls <- cvtable(summary(cv.modpls, MClassed = TRUE)) # plot(res.cv.modpls) # # modpls2 <- plsRglm(yhyptis, Xhyptis, 3, modele = "pls-glm-polr") # modpls2 # table(yhyptis, predict(modpls2$FinalModel, type = "class")) # biplot(modpls2$tt, modpls2$pp) # # modpls3 <- plsRglm( # yhyptis[-c(1, 11, 17, 22)], # Xhyptis[-c(1, 11, 17, 22), ], # 3, # modele = "pls-glm-polr", # dataPredictY = Xhyptis[c(1, 11, 17, 22), ] # ) # modpls3$ValsPredictY # cbind(modpls3$ValsPredictYCat, yhyptis[c(1, 11, 17, 22)]) # # hyptis.bootYX3 <- bootplsglm(modpls2, typeboot = "plsmodel", R = 1000, strata = unclass(yhyptis), sim = "permutation") # rownames(hyptis.bootYX3$t0) <- c("1|2\n", "2|3\n", "3|4\n", "Sabi\nnene", "Pin\nene", "Cine\nole", "Terpi\nnene", "Fenc\nhone", "Terpi\nnolene") # boxplots.bootpls(hyptis.bootYX3, xaxisticks = FALSE, ranget0 = TRUE) # plots.confints.bootpls(confints.bootpls(hyptis.bootYX3, typeBCa = FALSE), legendpos = "bottomleft", xaxisticks = FALSE) # points(1:9, hyptis.bootYX3$t0, col = "red", pch = 19) # # hyptis.bootYT3 <- bootplsglm(modpls2, R = 1000, strata = unclass(yhyptis), sim = "permutation") # rownames(hyptis.bootYT3$t0) <- c("Sabi\nnene", "Pin\nene", "Cine\nole", "Terpi\nnene", "Fenc\nhone", "Terpi\nnolene") # boxplots.bootpls(hyptis.bootYT3, xaxisticks = FALSE, ranget0 = TRUE) # plots.confints.bootpls(confints.bootpls(hyptis.bootYT3, typeBCa = FALSE), legendpos = "topright", xaxisticks = FALSE) # points(1:6, hyptis.bootYT3$t0, col = "red", pch = 19) ## ----rock-analysis, eval = run_examples--------------------------------------- # data(rock) # # modpls <- plsRglm( # area ~ ., # data = rock, # nt = 6, # modele = "pls-glm-family", # family = poisson(), # pvals.expli = TRUE # ) # modpls # colSums(modpls$pvalstep) # # modpls2 <- plsRglm( # area ~ .^2, # data = rock, # nt = 6, # modele = "pls-glm-family", # family = poisson(), # pvals.expli = TRUE # ) # modpls2 # colSums(modpls2$pvalstep) # # set.seed(123) # cv.modpls2 <- cv.plsRglm(area ~ .^2, data = rock, nt = 6, modele = "pls-glm-poisson", K = 8, NK = 100) # res.cv.modpls2 <- cvtable(summary(cv.modpls2)) # plot(res.cv.modpls2, type = "CVPreChi2") # # modpls3 <- plsRglm(area ~ .^2, data = rock, nt = 3, modele = "pls-glm-poisson") # # rock.bootYX3 <- bootplsglm(modpls3, typeboot = "plsmodel", R = 1000, sim = "antithetic") # rownames(rock.bootYX3$t0) <- c("Intercept\n", "peri\n", "shape\n", "perm\n", "peri.\nshape", "peri.\nperm", "shape.\nperm") # boxplots.bootpls(rock.bootYX3, indice = 2:7, xaxisticks = FALSE) # plots.confints.bootpls(confints.bootpls(rock.bootYX3), legendpos = "topright", xaxisticks = FALSE) # # rock.bootYT3 <- bootplsglm(modpls3, R = 1000, stabvalue = 1e10, sim = "antithetic") # rownames(rock.bootYT3$t0) <- c("peri\n", "shape\n", "perm\n", "peri.\nshape", "peri.\nperm", "shape.\nperm") # boxplots.bootpls(rock.bootYT3, xaxisticks = FALSE, ranget0 = TRUE) # plots.confints.bootpls(confints.bootpls(rock.bootYT3), legendpos = "topright", xaxisticks = FALSE) ## ----simulated-plsr, eval = run_examples-------------------------------------- # dimX <- 24 # Astar <- 2 # # simul_data_UniYX(dimX, Astar) # dataAstar2 <- as.data.frame(t(replicate(250, simul_data_UniYX(dimX, Astar)))) # # modpls2 <- plsR(Y ~ ., data = dataAstar2, 10, typeVC = "standard") # modpls2 # # set.seed(123) # cv.modpls2 <- cv.plsR(Y ~ ., data = dataAstar2, nt = 10, K = 10, NK = 100) # res.cv.modpls2 <- cvtable(summary(cv.modpls2)) # plot(res.cv.modpls2) ## ----simulated-logistic-continuous, eval = run_examples----------------------- # ydataAstar2 <- dataAstar2[, 1] # XdataAstar2 <- dataAstar2[, 2:(dimX + 1)] # ysimbin1 <- dicho(ydataAstar2) # # res <- plsR(ysimbin1, XdataAstar2, 10, typeVC = "standard", MClassed = TRUE) # res$MissClassed # res # # res$Probs # res$Probs.trc ## ----simulated-logistic-dichotomous, eval = run_examples---------------------- # bindataAstar2 <- as.data.frame(dicho(dataAstar2)) # resdicho <- plsR(Y ~ ., data = bindataAstar2, 10, typeVC = "standard", MClassed = TRUE) # # resdicho$MissClassed # resdicho # # resdicho$Probs # resdicho$Probs.trc ## ----validation-cornell, eval = run_examples---------------------------------- # data(Cornell) # XCornell <- Cornell[, 1:7] # yCornell <- Cornell[, 8] # # modpls <- plsR(yCornell, XCornell, 3) # modpls # modpls$uscores # modpls$pp # modpls$Coeffs # # modpls2 <- plsR(yCornell, XCornell, 4, typeVC = "standard") # modpls2$press.ind # modpls2$press.tot # modpls2$InfCrit ## ----validation-bordeaux, eval = run_examples--------------------------------- # set.seed(12345) # data(bordeaux) # Xbordeaux <- bordeaux[, 1:4] # ybordeaux <- factor(bordeaux$Quality, ordered = TRUE) # # modpls <- plsRglm(ybordeaux, Xbordeaux, 4, modele = "pls-glm-polr") # modpls # # XbordeauxNA <- Xbordeaux # XbordeauxNA[1, 1] <- NA # modplsNA <- plsRglm(ybordeaux, XbordeauxNA, 10, modele = "pls-glm-polr") # modplsNA ## ----export-latex, eval = run_examples && has_xtable-------------------------- # CVresults1 <- summary(cv.modpls.logit, MClassed = TRUE) # # resCVtab1 <- print( # xtable::xtable( # CVresults1[[1]][, c(1:6)], # digits = c(0, 1, 1, 0, 0, -1, 4), # caption = "Cross-validation results, $k=8$, part one" # ) # ) # # resCVtab2 <- print( # xtable::xtable( # CVresults1[[1]][, c(7:11)], # digits = c(0, -1, -1, 1, 1, 3), # caption = "Cross-validation results, $k=8$, part two" # ) # ) # # resCVtab1 # resCVtab2 ## ----session-information------------------------------------------------------ sessionInfo()