Skip to content
Snippets Groups Projects
Commit 7a4e2921 authored by RICQUIER FLORIAN's avatar RICQUIER FLORIAN :duck:
Browse files

add : first trying work on relative deviation

refs #13
parent daa3f8d5
No related branches found
No related tags found
1 merge request!1up : add missing imports
library(dplyr)
library(stringr)
library(ggplot2)
data(historical)
# Your provided pattern of base IDs
baseIds <- c("2006_06671AL", "2006_06671BL", "2009_09670AL", "2010_10526AL",
"2011_11526AL", "2012_12526AL", "2012_12526BL", "2013_13526AL",
"2013_13526BL", "2014_14526AL", "2014_14526BL", "2014_14526BL",
"2015_15671AL", "2015_15671BL", "2016_16526AL", "2016_16526BL",
"2017_17526AL", "2017_17526BL", "2018_18526AL", "2018_18526BL",
"2019_19526AL", "2019_19526BL", "2021_21526AL", "2021_21526BL",
"2022_22526AL", "2022_22526BL", "2023_23526AL", "2023_23526BL")
# Étape 1: Extraire la partie "baseId" et le suffixe (e.g., "ArrP", "ArrT", etc.) de chaque nom
outputsNames <- names(outputsProjects)
outputsProjects_base <- str_extract(outputsNames, "^[0-9]{4}_[0-9]{5}[A-Z]{2}")
suffixes <- str_extract(outputsNames, "(?<=_)[A-Za-z]+$")
# Étape 2: Créer un data.frame pour associer les noms de base et leurs suffixes
df <- data.frame(baseId = outputsProjects_base, suffix = suffixes, outputName = outputsNames, stringsAsFactors = FALSE)
# Étape 3: Initialiser une nouvelle liste pour stocker les résultats agrégés avec contenu aplati
aggregatedProjects <- list()
# Étape 4: Boucler sur chaque baseId pour agréger les suffixes et leurs contenus sans fusionner les noms
for(baseId in baseIds) {
# Trouver les noms correspondants à chaque baseId
matchedData <- df %>%
filter(baseId == !!baseId) %>%
select(suffix, outputName)
# Créer une sous-liste pour ce baseId
subList <- list()
# Remplir la sous-liste avec les suffixes et leur contenu sans changer les noms
for(i in 1:nrow(matchedData)) {
suffix <- matchedData$suffix[i]
outputName <- matchedData$outputName[i]
# Ajouter les éléments de la sous-liste directement sans modifier les noms
subList[[suffix]] <- outputsProjects[[outputName]][[1]] # Accède directement au premier élément pour enlever le niveau de liste
}
# Stocker cette sous-liste dans la liste agrégée
aggregatedProjects[[baseId]] <- subList
}
# Fonction pour calculer l'écart relatif entre deux valeurs maximales de YS
relative_diff_max <- function(ys1, ys2) {
epsilon <- 1e-9 # Pour éviter la division par zéro
max_ys1 <- max(ys1, na.rm = TRUE) + epsilon
max_ys2 <- max(ys2, na.rm = TRUE) + epsilon
return((max_ys1 - max_ys2) / max_ys2) # Calcul de l'écart relatif des max
}
# Boucle sur chaque élément de la liste aggregatedProjects pour calculer et stocker les écarts relatifs des valeurs maximales
for (element_name in names(aggregatedProjects)) {
element <- aggregatedProjects[[element_name]]
# Extraire les noms des sous-éléments (scénarios)
sub_elements <- names(element)
# Vérifier s'il y a au moins deux sous-éléments pour faire des combinaisons
if (length(sub_elements) < 2) {
cat("Skipping element:", element_name, "- not enough sub-elements\n")
next # Si moins de 2 sous-éléments, passer à l'élément suivant
}
# Générer toutes les combinaisons de 2 sous-éléments
combinations <- combn(sub_elements, 2, simplify = FALSE) # Générer les paires de combinaisons
# Initialiser une liste pour stocker les écarts relatifs des max pour ce baseId
comparison_results <- list()
# Calculer l'écart relatif pour chaque paire de sous-éléments sur les valeurs maximales
for (combo in combinations) {
sub1 <- combo[1]
sub2 <- combo[2]
ys1 <- element[[sub1]]$YS # Récupérer le vecteur YS du premier sous-élément
ys2 <- element[[sub2]]$YS # Récupérer le vecteur YS du second sous-élément
# Vérification pour s'assurer que les vecteurs "YS" existent
if (is.null(ys1) || is.null(ys2)) {
cat("Missing 'YS' in one of the sub-elements:", sub1, sub2, "in", element_name, "\n")
next # Sauter cette combinaison si "YS" est manquant
}
# Calculer l'écart relatif entre les valeurs maximales des deux vecteurs "YS"
relative_difference_max <- relative_diff_max(ys1, ys2)
# Stocker le résultat dans un nom clair du type "scenario1/scenario2"
comparison_name <- paste(sub1, sub2, sep = "/")
comparison_results[[comparison_name]] <- relative_difference_max
}
# Ajouter les résultats des comparaisons des valeurs maximales dans la sous-liste du baseId actuel
aggregatedProjects[[element_name]]$max_comparisons <- comparison_results
cat("Added max comparisons for", element_name, "\n")
}
# Extraire les résultats des max_comparisons pour créer un data.frame pour le barplot
results_max_df <- data.frame(baseId = character(), comparison = character(), relative_difference_max = numeric())
for (baseId in names(aggregatedProjects)) {
comparisons <- aggregatedProjects[[baseId]]$max_comparisons
if (!is.null(comparisons)) {
for (comparison_name in names(comparisons)) {
temp_df <- data.frame(
baseId = baseId,
comparison = comparison_name,
relative_difference_max = comparisons[[comparison_name]]
)
results_max_df <- rbind(results_max_df, temp_df)
}
}
}
# Créer le barplot des écarts relatifs maximaux avec des axes X et Y indépendants
ggplot(results_max_df, aes(x = comparison, y = relative_difference_max, fill = comparison)) +
geom_bar(stat = "identity", position = "dodge") +
facet_wrap(~ baseId, scales = "free") + # Ajustement dynamique de l'axe X et Y par baseId
labs(title = "Écarts relatifs des rendements maximaux par baseId",
x = "Comparaison de scénarios",
y = "Écart relatif des rendements maximaux (%)") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1),
strip.text = element_text(size = 8)) # Ajuste la taille du texte des facettes si nécessaire
# Créer une fonction pour donner un score théorique aux comparaisons
get_theoretical_order <- function(comparison) {
# Définir l'ordre théorique des comparaisons en fonction de l'impact
order <- c(
"Irri/Tem", "ArrT/Tem", "ArrP/Tem", "IrriMn/Tem", "Irri/IrriMn",
"ArrP/ArrT", "Dclt/Tem", "Dclt/Irri"
# Ajoute ici d'autres combinaisons selon ton modèle théorique
)
# Retourner l'indice dans cet ordre (plus l'indice est petit, plus l'écart est théorique élevé)
return(match(comparison, order, nomatch = length(order) + 1)) # Si la combinaison n'existe pas, donner une valeur haute
}
# Appliquer cette fonction à chaque comparaison pour créer une colonne avec cet ordre théorique
results_max_df$theoretical_order <- sapply(results_max_df$comparison, get_theoretical_order)
# Créer le barplot des écarts relatifs maximaux avec des axes X et Y indépendants, et ordre inversé
num_comparisons <- length(unique(results_max_df$comparison))
sexy_colors <- scales::hue_pal()(num_comparisons) # Génère un nombre de couleurs égal au nombre de comparaisons
# Créer le barplot des écarts relatifs maximaux avec des axes X et Y indépendants, et rendu "sexy"
ggplot(results_max_df, aes(x = reorder(comparison, -theoretical_order), y = relative_difference_max, fill = comparison)) +
geom_bar(stat = "identity", position = "dodge", color = "black", linewidth = 0.3, width = 0.8) + # Utilisation de linewidth au lieu de size
facet_wrap(~ baseId, scales = "free") + # Ajustement dynamique de l'axe X et Y par baseId
labs(title = "Comparaison des écarts relatifs des rendements maximaux",
subtitle = "Par scénario d'irrigation et par essai (BaseID)", # Sous-titre pour plus d'infos
x = "Comparaison de scénarios",
y = "Écart relatif des rendements maximaux (%)") +
scale_fill_manual(values = sexy_colors) + # Palette de couleurs générée automatiquement
theme_minimal(base_size = 14) + # Thème minimal avec une taille de police ajustée
theme(
plot.title = element_text(face = "bold", hjust = 0.5, size = 18), # Titre centré et en gras
plot.subtitle = element_text(hjust = 0.5, size = 12), # Sous-titre centré
axis.title.x = element_text(face = "bold"), # Axe X en gras
axis.title.y = element_text(face = "bold"), # Axe Y en gras
axis.text.x = element_text(angle = 45, hjust = 1, size = 10, face = "italic"), # Labels X inclinés et en italique
axis.text.y = element_text(size = 12), # Taille du texte de l'axe Y augmentée
legend.position = "none", # Cacher la légende pour un effet épuré
strip.text = element_text(face = "bold", size = 12), # Taille et style du texte des facettes
panel.grid.major = element_line(color = "grey80"), # Grille légère pour un effet subtil
panel.grid.minor = element_blank() # Pas de lignes de grille mineures
)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment