update C01Lb_ml1: use of {exploreit} functions

Author: GuyliannEngels

inst/tutorials/C01Lb_ml1/C01Lb_ml1.Rmd

@@ -16,6 +16,7 @@ runtime: shiny_prerendered
 BioDataScience3::learnr_setup()
 SciViews::R()
 library(mlearning)
+library(exploreit)
 library(rsample)
 
 # exercice preparation --------
@@ -30,13 +31,6 @@ bio_split <- initial_split(bio, prop = 2/3)
 bio_train <- training(bio_split)
 bio_test <- testing(bio_split)
 
-#n <- nrow(bio)
-#n_train <- round(n * 2/3)
-#set.seed(164)
-#train <- sample(1:n, n_train)
-#bio_train <- bio[ train, ]
-#bio_test <- bio[ -train, ]
-
 ## Creation d'un modèle lda
 bio_lda <- mlLda(data = bio_train, gender ~ .)
 
@@ -53,197 +47,6 @@ BioDataScience3::learnr_banner()
 BioDataScience3::learnr_server(input, output, session)
 ```
 
-```{r}
-as.prcomp <- function(x, ...)
-  UseMethod("as.prcomp")
-
-as.prcomp.default <- function(x, ...)
-  stop("No method to convert this object into a 'prcomp'")
-
-as.prcomp.prcomp <- function(x, ...)
-  x
-
-as.prcomp.princomp <- function(x, ...)
-  structure(list(sdev = as.numeric(x$sdev), rotation = unclass(x$loadings),
-    center = x$center, scale = x$scale, x = as.matrix(x$scores)),
-    class = "prcomp")
-
-# Comparison of pcomp() -> as.prcomp() with prcomp() directly
-# Almost the same, only no rownames for x (is it important?)
-#iris_prcomp_pcomp <- as.prcomp(pcomp(iris[, -5], scale = TRUE))
-#iris_prcomp <- prcomp(iris[, -5], scale = TRUE)
-
-# Now, broom methods can be defined simply by converting into prcomp objects
-augment.princomp <- function(x, data = NULL, newdata, ...)
-  if (missing(newdata)) {
-  augment(as.prcomp(x), data = data, ...)
-  } else {
-    augment(as.prcomp(x), data = data, newdata = newdata, ...)
-  }
-
-tidy.princomp <- function(x, matrix = "u", ...)
-  tidy(as.prcomp(x), matrix = matrix, ...)
-
-# There is no glance.prcomp() method
-
-# There is a problem with pcomp() that returns a data.frame in scores,
-# while it is a matrix in the original princomp object. pca() corrects this
-pca <- function(x, ...) {
-  res <- SciViews::pcomp(x, ...)
-  # Change scores into a matrix
-  res$scores <- as.matrix(res$scores)
-  res
-}
-
-scale_axes <- function(data, aspect.ratio = 1) {
-  range_x <- range(data[, 1])
-  span_x <- abs(max(range_x) - min(range_x))
-  range_y <- range(data[, 2])
-  span_y <- abs(max(range_y) - min(range_y))
-  if ((span_y / aspect.ratio) > span_x) {
-    # Adjust range_x
-    span_x_2 <- span_y / aspect.ratio / 2
-    range_x_mid <- sum(range_x) / 2
-    range_x <- c(range_x_mid - span_x_2, range_x_mid + span_x_2)
-  } else {
-    # Adjust range_y
-    span_y_2 <- span_x * aspect.ratio / 2
-    range_y_mid <- sum(range_y) / 2
-    range_y <- c(range_y_mid - span_y_2, range_y_mid + span_y_2)
-  }
-  list(x = range_x, y = range_y)
-}
-
-autoplot.pcomp <- function(object,
-type = c("screeplot", "altscreeplot", "loadings", "correlations", "scores", "biplot"),
-choices = 1L:2L, name = deparse(substitute(object)), ar.length = 0.1,
-circle.col = "gray", col = "black", fill = "gray", scale = 1, aspect.ratio = 1,
-repel = FALSE, labels, title, xlab, ylab, ...) {
-  type = match.arg(type)
-
-  if (missing(title))
-    title <- paste(name, type, sep = " - ")
-
-  contribs <- paste0(names(object$sdev), " (",
-    round((object$sdev^2/object$totdev^2) * 100, digits = 1), "%)")[choices]
-
-  scores <- as.data.frame(object$scores[, choices])
-  names(scores) <- c("x", "y")
-  if (!missing(labels)) {
-    if (length(labels) != nrow(scores))
-      stop("You must provide a character vector of length ", nrow(scores),
-        " for 'labels'")
-    scores$labels <- labels
-  } else {# Default labels are row numbers
-    scores$labels <- 1:nrow(scores)
-  }
-
-  lims <- scale_axes(scores, aspect.ratio = aspect.ratio)
-
-  if (!missing(col)) {
-    if (length(col) != nrow(scores))
-      stop("You must provide a vector of length ", nrow(scores), " for 'col'")
-    scores$color <- col
-    scores_formula <- y ~ x %col=% color %label=% labels
-  } else {
-    if (missing(labels)) {
-      scores_formula <- y ~ x %label=% labels
-    } else {
-      scores_formula <- y ~ x %col=% labels %label=% labels
-    }
-  }
-
-  res <- switch(type,
-    screeplot = object %>.% # Classical screeplot
-      tidy(., "pcs") %>.%
-      chart(data = ., std.dev^2 ~ PC) +
-      geom_col(col = col, fill = fill) +
-      labs(y = "Variances", title = title),
-
-    altscreeplot = object %>.% # screeplot represented by dots and lines
-      tidy(., "pcs") %>.%
-      chart(data = ., std.dev^2 ~ PC) +
-      geom_line(col = col) +
-      geom_point(col = "white", fill = col, size = 2, shape = 21, stroke = 3) +
-      labs(y = "Variances", title = title),
-
-    loadings = object %>.% # Plots of the variables
-      tidy(., "variables") %>.%
-      spread(., key = PC, value = value) %>.%
-      #rename_if(., is.numeric, function(x) paste0("PC", x)) %>.%
-      select(., c(1, choices + 1)) %>.%
-      set_names(., c("labels", "x", "y")) %>.%
-      chart(data = ., y ~ x %xend=% 0 %yend=% 0 %label=% labels) +
-        annotate("path", col = circle.col,
-          x = cos(seq(0, 2*pi, length.out = 100)),
-          y = sin(seq(0, 2*pi, length.out = 100))) +
-        geom_hline(yintercept = 0, col = circle.col) +
-        geom_vline(xintercept = 0, col = circle.col) +
-        geom_segment(arrow = arrow(length = unit(ar.length, "inches"),
-          ends = "first")) +
-        ggrepel::geom_text_repel(hjust = "outward", vjust = "outward") +
-        coord_fixed(ratio = 1) +
-        labs(x = contribs[1], y = contribs[2], title = title),
-
-    correlations = object %>.% # Correlations plot
-      Correlation(.) %>.%
-      as_tibble(., rownames = "labels") %>.%
-      select(., c(1, choices + 1)) %>.%
-      set_names(., c("labels", "x", "y")) %>.%
-      chart(data = ., y ~ x %xend=% 0 %yend=% 0 %label=% labels) +
-      annotate("path", col = circle.col,
-        x = cos(seq(0, 2*pi, length.out = 100)),
-        y = sin(seq(0, 2*pi, length.out = 100))) +
-      geom_hline(yintercept = 0, col = circle.col) +
-      geom_vline(xintercept = 0, col = circle.col) +
-      geom_segment(arrow = arrow(length = unit(ar.length, "inches"),
-        ends = "first")) +
-      ggrepel::geom_text_repel(hjust = "outward", vjust = "outward") +
-      coord_fixed(ratio = 1) +
-      labs(x = contribs[1], y = contribs[2], title = title),
-
-    scores = scores %>.% # Plot of the individuals
-      chart(data = ., scores_formula) +
-      geom_hline(yintercept = 0, col = circle.col) +
-      geom_vline(xintercept = 0, col = circle.col) +
-      coord_fixed(ratio = 1, xlim = lims$x, ylim = lims$y, expand = TRUE) +
-      labs(x = contribs[1], y = contribs[2], title = title) +
-      theme(legend.position = "none"),
-
-    biplot = object %>.% # Biplot using ggfortify function
-      as.prcomp(.) %>.%
-      ggfortify:::autoplot.prcomp(., x = choices[1], y = choices[2],
-        scale = scale, size = -1, label = TRUE, loadings = TRUE,
-        loadings.label = TRUE) +
-      geom_hline(yintercept = 0, col = circle.col) +
-      geom_vline(xintercept = 0, col = circle.col) +
-      theme_sciviews() +
-      labs(x = contribs[1], y = contribs[2], title = title),
-
-    stop("Unrecognized type, must be 'screeplot', 'altscreeplot', loadings', 'correlations', 'scores' or 'biplot'")
-  )
-
-  if (type == "scores") {
-    if (isTRUE(repel)) {
-      res <- res + geom_point() + ggrepel::geom_text_repel()
-    } else {# Use text
-      res <- res + geom_text()
-    }
-  }
-
-  if (!missing(xlab))
-    res <- res + xlab(xlab)
-  if (!missing(ylab))
-    res <- res + ylab(ylab)
-  res
-}
-
-chart.pcomp <- function(data, choices = 1L:2L, name = deparse(substitute(data)),
-..., type = NULL, env = parent.frame())
-  autoplot.pcomp(data, choices = choices, name = name, ..., type = type, env = env)
-class(chart.pcomp) <- c("function", "subsettable_type")
-```
-
 ------------------------------------------------------------------------
 
 ## Objectifs