Fini d'ajouter les CAH par dominante 3A
This commit is contained in:
parent
58a4599213
commit
a0e91826cd
2 changed files with 255 additions and 0 deletions
195
cah-analyse.qmd
Normal file
195
cah-analyse.qmd
Normal file
|
|
@ -0,0 +1,195 @@
|
||||||
|
---
|
||||||
|
title: Analyse des résultats de CAH
|
||||||
|
author: Louis Lacoste
|
||||||
|
execute:
|
||||||
|
echo: false
|
||||||
|
warning: false
|
||||||
|
fig-width: 10
|
||||||
|
fig-height: 10
|
||||||
|
format: html
|
||||||
|
---
|
||||||
|
|
||||||
|
## Description des données
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
knitr::opts_chunk$set(echo = FALSE)
|
||||||
|
library(ggplot2)
|
||||||
|
library(plotly)
|
||||||
|
library(ggokabeito)
|
||||||
|
library(RColorBrewer)
|
||||||
|
library(patchwork)
|
||||||
|
|
||||||
|
library(here)
|
||||||
|
|
||||||
|
library(knitr)
|
||||||
|
|
||||||
|
library(dplyr)
|
||||||
|
library(tidyr)
|
||||||
|
library(stringr)
|
||||||
|
library(DT)
|
||||||
|
|
||||||
|
|
||||||
|
data <- read.csv(file.path(here(), "data", "03_cah_results.csv"))
|
||||||
|
colnames(data)[6:ncol(data) - 1] <- c(
|
||||||
|
"1AC-OUVERTURE", "1AC-MI",
|
||||||
|
"2A-UEchoix-S1-UC1", "2A-UEchoix-S1-UC2", "2A-UEchoix-S2-UC3",
|
||||||
|
"2A-UEchoix-S2-UC4",
|
||||||
|
"2A-UEchoix-S2-UC5", "2A-UEchoix-S2-UC6",
|
||||||
|
"2A-Projet-S2"
|
||||||
|
)
|
||||||
|
data <- data %>%
|
||||||
|
mutate_if(sapply(data, is.character), as.factor)
|
||||||
|
```
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
# TODO Croiser les données pour extraire le nom des UCs et remplacer les facteurs
|
||||||
|
|
||||||
|
data_details_sequence <- read.csv(file.path(here(), "data", "details-sequence-nettoyes.csv"))
|
||||||
|
|
||||||
|
for (code_bloc in colnames(data)[6:ncol(data) - 1]) {
|
||||||
|
# code_bloc <- "1AC-OUVERTURE"
|
||||||
|
matching_code_cours <- data_details_sequence[which(data_details_sequence[["code_bloc"]] == code_bloc), c("code_cours", "cours")]
|
||||||
|
row_id_in_matching <- which(matching_code_cours[["code_cours"]] %in% levels(data[[code_bloc]]))
|
||||||
|
levels(data[[code_bloc]]) <- matching_code_cours[row_id_in_matching, "cours"]
|
||||||
|
}
|
||||||
|
```
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
# CAH pour toutes les dominantes
|
||||||
|
|
||||||
|
|
||||||
|
Voici un extrait des données obtenues après tout le traitement :
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
#| width: 50%
|
||||||
|
kable(head(data[, -1], 3))
|
||||||
|
effectif_cluster <- table(data[["cluster"]])
|
||||||
|
```
|
||||||
|
|
||||||
|
:::{.callout-caution}
|
||||||
|
A cause du format peu pratique pour l'extraction, nous avons un grand nombre de NAs mais malgré tout nous avons pu réaliser une CAH sur les données et obtenir `r max(data[["cluster"]])` clusters différents.
|
||||||
|
|
||||||
|
Nous avons nous même fixé ce nombre dans le fichier `03_CAH_clust.R`.
|
||||||
|
:::
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
nb_3A_min <- 0
|
||||||
|
data <- data %>%
|
||||||
|
group_by(dominante3A) %>%
|
||||||
|
mutate(dominante3A = ifelse(n() < nb_3A_min, "Autre", dominante3A))
|
||||||
|
```
|
||||||
|
|
||||||
|
Les dominantes de 3A sont nombreuses, nous allons donc rassembler celles dont
|
||||||
|
l'effectif est de moins de `r nb_3A_min` étudiants dans une catégorie "Autre".
|
||||||
|
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
getPalette <- colorRampPalette(colors = palette_okabe_ito())
|
||||||
|
plot_prop_cluster <- function(orig_data, eff, ...) {
|
||||||
|
data <- orig_data
|
||||||
|
|
||||||
|
colorCount <- length(unique(data[["uc"]]))
|
||||||
|
levels(data$cluster) <- paste0(levels(data$cluster), " (N=", eff, ")")
|
||||||
|
p <- ggplot(data, ...) +
|
||||||
|
aes(x = "", y = nb, fill = uc, label = nb) +
|
||||||
|
geom_bar(position = "fill", stat = "identity") +
|
||||||
|
theme_bw() +
|
||||||
|
xlab("Cluster") +
|
||||||
|
ylab("Proportion dans le cluster") +
|
||||||
|
labs(fill = "Choix") +
|
||||||
|
theme(axis.title.y = element_text(angle = 90, vjust = .5, hjust = 1), aspect.ratio = 1) +
|
||||||
|
theme(legend.position = "bottom") +
|
||||||
|
guides(fill = guide_legend(nrow = 8, byrow = TRUE)) +
|
||||||
|
scale_fill_manual(values = getPalette(colorCount), ) +
|
||||||
|
# coord_flip() +
|
||||||
|
scale_x_discrete() +
|
||||||
|
# coord_polar("y", start=0) +
|
||||||
|
facet_wrap(vars(data[["cluster"]]))
|
||||||
|
|
||||||
|
return(p)
|
||||||
|
}
|
||||||
|
```
|
||||||
|
|
||||||
|
:::{.panel-tabset}
|
||||||
|
|
||||||
|
### Graphiques
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
#| plotly: true
|
||||||
|
#| result: asis
|
||||||
|
|
||||||
|
ac <- NULL
|
||||||
|
vec_sequences <- (colnames(data)[3:ncol(data) - 1])
|
||||||
|
htmltools::tagList(lapply(vec_sequences, function(sequence) {
|
||||||
|
ac <- as.data.frame(table(data[["cluster"]], data[[sequence]], useNA = "ifany"))
|
||||||
|
colnames(ac) <- c("cluster", "uc", "nb")
|
||||||
|
ac <- ac %>%
|
||||||
|
group_by(cluster) %>%
|
||||||
|
mutate(Prop = nb / sum(nb), uc = str_wrap(uc, 32))
|
||||||
|
p <- ggplotly(ac %>% plot_prop_cluster(eff = effectif_cluster) + ggtitle(str_wrap(paste("Proportion pour", sequence), 20)))
|
||||||
|
p
|
||||||
|
}))
|
||||||
|
```
|
||||||
|
|
||||||
|
### Tableaux
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
#| tbl-cap: !expr 'paste("Table des proportions de choix par cluster pour ",(colnames(data)[3:ncol(data)-1]))'
|
||||||
|
#| result: asis
|
||||||
|
ac <- NULL
|
||||||
|
vec_sequences <- (colnames(data)[3:ncol(data) - 1])
|
||||||
|
for (sequence in vec_sequences) {
|
||||||
|
ac <- as.data.frame(table(data[["cluster"]], data[[sequence]], useNA = "ifany"))
|
||||||
|
colnames(ac) <- c("cluster", "uc", "nb")
|
||||||
|
ac <- ac %>%
|
||||||
|
group_by(cluster) %>%
|
||||||
|
mutate(Prop = nb / sum(nb), uc = str_wrap(uc, 30))
|
||||||
|
ac_table <- ac %>%
|
||||||
|
select(-nb) %>%
|
||||||
|
pivot_wider(names_from = uc, values_from = Prop)
|
||||||
|
print(ac_table %>% datatable(filter = "top"))
|
||||||
|
}
|
||||||
|
```
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
:::
|
||||||
|
|
||||||
|
|
||||||
|
# CAH par dominante
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
per_dominante_folder <- file.path(here(), "data", "04_CAH_par_dominante")
|
||||||
|
cah_data_list <- list.files(per_dominante_folder)
|
||||||
|
|
||||||
|
backtick <- "`"
|
||||||
|
```
|
||||||
|
|
||||||
|
Nous avons ensuité réalisé des CAH par dominante pour analyser les profils
|
||||||
|
d'étudiants. Pour cela il a fallu définir un seuil, celui ci est de 20 étudiants
|
||||||
|
au moins dans la dominante.
|
||||||
|
|
||||||
|
Voici la liste de fichiers obtenue : `r toString(paste0(backtick, cah_data_list, backtick))`
|
||||||
|
|
||||||
|
Et ci-dessous des onglets par dominante considérée.
|
||||||
|
|
||||||
|
:::{.panel-tabset}
|
||||||
|
|
||||||
|
|
||||||
|
```{r write_tabs}
|
||||||
|
#| warning: false
|
||||||
|
#| output: asis
|
||||||
|
|
||||||
|
src <- lapply(seq_len(length(cah_data_list)), function(i) {
|
||||||
|
knitr::knit_expand(file.path(here(), "tabset.qmd"))
|
||||||
|
})
|
||||||
|
|
||||||
|
res <- knitr::knit_child(text = unlist(src))
|
||||||
|
cat(res, sep = "\n")
|
||||||
|
```
|
||||||
|
|
||||||
|
:::
|
||||||
60
tabset.qmd
Normal file
60
tabset.qmd
Normal file
|
|
@ -0,0 +1,60 @@
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
data_domi <- read.csv(file.path(per_dominante_folder, cah_data_list[{{i}}]), check.names = FALSE)
|
||||||
|
|
||||||
|
nom_dominante <- as.character(unique(data_domi[["dominante3A"]]))
|
||||||
|
|
||||||
|
colnames(data_domi[6:ncol(data_domi)-1]) <- c(
|
||||||
|
"1AC-OUVERTURE", "1AC-MI",
|
||||||
|
"2A-UEchoix-S1-UC1", "2A-UEchoix-S1-UC2", "2A-UEchoix-S2-UC3",
|
||||||
|
"2A-UEchoix-S2-UC4",
|
||||||
|
"2A-UEchoix-S2-UC5", "2A-UEchoix-S2-UC6",
|
||||||
|
"2A-Projet-S2"
|
||||||
|
)
|
||||||
|
|
||||||
|
data_domi <- data_domi %>%
|
||||||
|
mutate_if(sapply(data_domi, is.character), as.factor)
|
||||||
|
|
||||||
|
for (code_bloc in colnames(data_domi)[6:ncol(data_domi) - 1]) {
|
||||||
|
# code_bloc <- "1AC-OUVERTURE"
|
||||||
|
matching_code_cours <- data_details_sequence[which(data_details_sequence[["code_bloc"]] == code_bloc), c("code_cours", "cours")]
|
||||||
|
row_id_in_matching <- which(matching_code_cours[["code_cours"]] %in% levels(data_domi[[code_bloc]]))
|
||||||
|
levels(data_domi[[code_bloc]]) <- matching_code_cours[row_id_in_matching, "cours"]
|
||||||
|
}
|
||||||
|
|
||||||
|
effectif_cluster_domi <- table(data_domi[["cluster"]])
|
||||||
|
```
|
||||||
|
|
||||||
|
### Dominante : `r nom_dominante`
|
||||||
|
|
||||||
|
#### Graphiques
|
||||||
|
|
||||||
|
```{r}
|
||||||
|
#| plotly: true
|
||||||
|
#| result: asis
|
||||||
|
|
||||||
|
ac <- NULL
|
||||||
|
vec_sequences <- (colnames(data_domi)[4:ncol(data_domi)-1])
|
||||||
|
htmltools::tagList(lapply(vec_sequences, function (sequence) {
|
||||||
|
ac <- as.data.frame(table(data_domi[["cluster"]], data_domi[[sequence]], useNA = "ifany"))
|
||||||
|
colnames(ac) <- c("cluster", "uc", "nb")
|
||||||
|
ac <- ac %>% group_by(cluster) %>% mutate(Prop = nb/sum(nb), uc = str_wrap(uc,32))
|
||||||
|
p <- ggplotly(ac %>% plot_prop_cluster(eff = effectif_cluster_domi) + ggtitle(paste("Proportion pour", sequence, "- domaine :", nom_dominante)))
|
||||||
|
p
|
||||||
|
}))
|
||||||
|
```
|
||||||
|
|
||||||
|
#### Tables
|
||||||
|
```{r}
|
||||||
|
#| tbl-cap: !expr 'paste("Table des proportions de choix par cluster pour ",(colnames(data)[3:ncol(data)-1]))'
|
||||||
|
#| result: asis
|
||||||
|
ac <- NULL
|
||||||
|
vec_sequences <- (colnames(data_domi)[4:ncol(data_domi)-1])
|
||||||
|
for(sequence in vec_sequences) {
|
||||||
|
ac <- as.data.frame(table(data_domi[["cluster"]], data_domi[[sequence]], useNA = "ifany"))
|
||||||
|
colnames(ac) <- c("cluster", "uc", "nb")
|
||||||
|
ac <- ac %>% group_by(cluster) %>% mutate(Prop = nb/sum(nb), uc = str_wrap(uc,30))
|
||||||
|
ac_table <- ac %>% select(-nb) %>% pivot_wider(names_from = uc, values_from = Prop)
|
||||||
|
print(ac_table %>% datatable(filter = "top") %>% formatRound(columns = - 1, digits = 3))
|
||||||
|
}
|
||||||
|
```
|
||||||
Loading…
Add table
Reference in a new issue