R Notebook
Packages
library(corrplot)## corrplot 0.94 loadedlibrary(dplyr)##
## Attachement du package : 'dplyr'## Les objets suivants sont masqués depuis 'package:stats':
##
## filter, lag## Les objets suivants sont masqués depuis 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(ggplot2)
library(gridExtra)##
## Attachement du package : 'gridExtra'## L'objet suivant est masqué depuis 'package:dplyr':
##
## combinelibrary(survival)
library(survminer)## Warning: le package 'survminer' a été compilé avec la version R 4.4.3## Le chargement a nécessité le package : ggpubr## Warning: le package 'ggpubr' a été compilé avec la version R 4.4.2##
## Attachement du package : 'survminer'## L'objet suivant est masqué depuis 'package:survival':
##
## myelomaThe aim of this project is to use survival analysis to study the relationship between a customer’s gym membership lifetime and probability of churning.
Chargement des données
df <- read.csv("gym_churn_us.csv")
# Aperçu rapide pour vérifier que tout est là
str(df)## 'data.frame': 4000 obs. of 14 variables:
## $ gender : int 1 0 0 0 1 1 1 0 1 0 ...
## $ Near_Location : int 1 1 1 1 1 1 1 1 1 1 ...
## $ Partner : int 1 0 1 1 1 0 1 0 1 0 ...
## $ Promo_friends : int 1 0 0 1 1 0 1 0 1 0 ...
## $ Phone : int 0 1 1 1 1 1 0 1 1 1 ...
## $ Contract_period : int 6 12 1 12 1 1 6 1 1 1 ...
## $ Group_visits : int 1 1 0 1 0 1 1 0 1 0 ...
## $ Age : int 29 31 28 33 26 34 32 30 23 31 ...
## $ Avg_additional_charges_total : num 14.2 113.2 129.4 62.7 198.4 ...
## $ Month_to_end_contract : num 5 12 1 12 1 1 6 1 1 1 ...
## $ Lifetime : int 3 7 2 2 3 3 2 0 1 11 ...
## $ Avg_class_frequency_total : num 0.0204 1.9229 1.8591 3.2056 1.1139 ...
## $ Avg_class_frequency_current_month: num 0 1.91 1.74 3.36 1.12 ...
## $ Churn : int 0 0 0 0 0 0 0 1 0 0 ...summary(df)## gender Near_Location Partner Promo_friends
## Min. :0.0000 Min. :0.0000 Min. :0.0000 Min. :0.0000
## 1st Qu.:0.0000 1st Qu.:1.0000 1st Qu.:0.0000 1st Qu.:0.0000
## Median :1.0000 Median :1.0000 Median :0.0000 Median :0.0000
## Mean :0.5102 Mean :0.8452 Mean :0.4868 Mean :0.3085
## 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:1.0000
## Max. :1.0000 Max. :1.0000 Max. :1.0000 Max. :1.0000
## Phone Contract_period Group_visits Age
## Min. :0.0000 Min. : 1.000 Min. :0.0000 Min. :18.00
## 1st Qu.:1.0000 1st Qu.: 1.000 1st Qu.:0.0000 1st Qu.:27.00
## Median :1.0000 Median : 1.000 Median :0.0000 Median :29.00
## Mean :0.9035 Mean : 4.681 Mean :0.4123 Mean :29.18
## 3rd Qu.:1.0000 3rd Qu.: 6.000 3rd Qu.:1.0000 3rd Qu.:31.00
## Max. :1.0000 Max. :12.000 Max. :1.0000 Max. :41.00
## Avg_additional_charges_total Month_to_end_contract Lifetime
## Min. : 0.1482 Min. : 1.000 Min. : 0.000
## 1st Qu.: 68.8688 1st Qu.: 1.000 1st Qu.: 1.000
## Median :136.2202 Median : 1.000 Median : 3.000
## Mean :146.9437 Mean : 4.323 Mean : 3.725
## 3rd Qu.:210.9496 3rd Qu.: 6.000 3rd Qu.: 5.000
## Max. :552.5907 Max. :12.000 Max. :31.000
## Avg_class_frequency_total Avg_class_frequency_current_month Churn
## Min. :0.000 Min. :0.000 Min. :0.0000
## 1st Qu.:1.181 1st Qu.:0.963 1st Qu.:0.0000
## Median :1.833 Median :1.720 Median :0.0000
## Mean :1.879 Mean :1.767 Mean :0.2652
## 3rd Qu.:2.536 3rd Qu.:2.510 3rd Qu.:1.0000
## Max. :6.024 Max. :6.147 Max. :1.0000Préparation des données
# Transformation des variables catégorielles en facteurs
cols_facteurs <- c("gender", "Near_Location", "Partner", "Promo_friends",
"Phone", "Group_visits", "Churn")
# On applique la transformation sur les colonnes concernées
df[cols_facteurs] <- lapply(df[cols_facteurs], factor)
# Vérification : 'Lifetime' doit rester numérique pour l'analyse de survie
class(df$Lifetime) # Doit afficher "numeric" ou "integer"## [1] "integer"# On s'assure que Churn est bien 0 ou 1 pour le calcul
df$Churn_num <- as.numeric(as.character(df$Churn))Numerical :
Contract period Age Average additional charge in total Month to end of contract Average class frequency (total) Average class frequency (current month)
Categorical :
Gender Near location: If the user lives or works in the neighbourhood where the gym is located. Partner: If the user works in an associated company. Promo friends: If the user originally signed up through “bring a friend” offer. Phone: If the user provided their phone number. Group visits: If the user visits the gym in groups.
Target variables :
Churn (Categorical) Lifetime (Numerical): Time in months since user first arrived in the gym (and before they churned).
Statistiques descriptives
# --- A. Analyse Univariée : Qui sont nos clients ? ---
# 1. Variables Démographiques et Catégorielles
p1 <- ggplot(df, aes(x = gender, fill = Churn)) +
geom_bar(position = "fill") +
labs(title = "Genre", y = "Proportion", x = NULL) + theme_minimal()
p2 <- ggplot(df, aes(x = Near_Location, fill = Churn)) +
geom_bar(position = "fill") +
labs(title = "Proximité", y = NULL, x = NULL) + theme_minimal()
p3 <- ggplot(df, aes(x = Partner, fill = Churn)) +
geom_bar(position = "fill") +
labs(title = "Entreprise Partenaire", y = NULL, x = NULL) + theme_minimal()
p4 <- ggplot(df, aes(x = Promo_friends, fill = Churn)) +
geom_bar(position = "fill") +
labs(title = "Promo Parrainage", y = NULL, x = NULL) + theme_minimal()
# Affichage de la grille
grid.arrange(p1, p2, p3, p4, ncol = 2, top = "Impact des variables catégorielles sur le Churn (Proportion)")
# --- B. Analyse des variables numériques (Boxplots) ---
# On compare la distribution des variables selon si le client est parti (1) ou resté (0)
b1 <- ggplot(df, aes(x = Churn, y = Age, fill = Churn)) +
geom_boxplot() +
labs(title = "Âge", x = NULL) + theme_minimal() + theme(legend.position="none")
b2 <- ggplot(df, aes(x = Churn, y = Lifetime, fill = Churn)) +
geom_boxplot() +
labs(title = "Durée de vie (Mois)", x = NULL) + theme_minimal() + theme(legend.position="none")
b3 <- ggplot(df, aes(x = Churn, y = Avg_class_frequency_current_month, fill = Churn)) +
geom_boxplot() +
labs(title = "Fréquence (Mois en cours)", x = NULL, y = "Visites/Semaine") + theme_minimal() + theme(legend.position="none")
b4 <- ggplot(df, aes(x = Churn, y = Contract_period, fill = Churn)) +
geom_boxplot() +
labs(title = "Durée Contrat", x = NULL, y = "Mois") + theme_minimal() + theme(legend.position="none")
grid.arrange(b1, b2, b3, b4, ncol = 2, top = "Distribution des variables numériques selon le Churn")
# --- C. Matrice de corrélation ---
# On ne garde que les colonnes numériques pour la corrélation
nums <- unlist(lapply(df, is.numeric))
cor_matrix <- cor(df[, nums])
corrplot(cor_matrix, method = "color", type = "upper",
tl.col = "black", tl.srt = 45, title = "Matrice de Corrélation", mar=c(0,0,1,0))
A. Analyse Univariée : Qui sont nos clients ?
- Le Genre
Les deux barres (0 et 1) sont quasi identiques. La proportion de bleu est la même chez les hommes et les femmes. Le genre n’est pas une variable discriminante. Être un homme ou une femme n’influence pas la décision de partir.
- Proximité
La barre bleue est nettement plus haute pour le groupe 0. L’éloignement géographique est un facteur de risque. Les clients qui n’habitent pas ou ne travaillent pas dans le quartier ont un taux de désabonnement plus élevé.
- Entreprise partenaire
La différence est flagrante. Le groupe 1 (Venant d’une entreprise partenaire) a une zone bleue beaucoup plus petite que le groupe 0. C’est un facteur protecteur puissant. Les employés venant via leur CE ou leur entreprise sont beaucoup plus fidèles. Cela valide l’efficacité du canal B2B.
- Promo parrainage
Ceux qui viennent avec un code promo “ami” (Groupe 1) partent moins que ceux venus seuls. L’effet de réseau social fidélise. Venir avec un ami crée un engagement moral et social qui réduit le risque de churn.
B. Analyse des variables numériques (Boxplots)
- Âge
La boîte turquoise est décalée vers le bas. La médiane d’âge des partants est autour de 26-27 ans, contre 30 ans pour les fidèles. La jeunesse est un facteur de volatilité. Les clients plus âgés ont probablement une vie plus stabilisée et des revenus plus réguliers, favorisant l’engagement à long terme.
- Durée de vie
La boîte turquoise est écrasée tout en bas. La médiane est à peine à 1 ou 2 mois. Cela confirme l’hypothèse de la “mortalité infantile” du client. Ceux qui partent le font quasi immédiatement. Si un client dépasse le cap des 5-6 mois (boîte saumon), il est “sauvé”.
- Fréquence
- Fidèles (0) : Médiane à 2 visites/semaine.
- Partants (1) : Médiane à 1 visite/semaine (et beaucoup sont à 0).
Le décrochage sportif précède le désabonnement administratif. Un client qui passe sous la barre de 1 visite/semaine est en zone rouge.
- Durée contrat La boîte turquoise est une ligne plate en bas. Quasiment 100% des désabonnements proviennent des contrats courts (1 mois). Les contrats longs (6 ou 12 mois, visibles dans la boîte saumon) agissent comme un verrou très efficace.
L’analyse descriptive dessine le profil type du client à risque : C’est un jeune homme ou une jeune femme de moins de 27 ans, inscrit sur un contrat court (1 mois), qui ne vient plus qu’une fois par semaine ou moins, et qui n’a pas encore passé le cap critique des 2 premiers mois d’ancienneté.
C. Matrice de corrélation
Nous avons un carré bleu foncé (quasi noir) à l’intersection de Contract_period et Month_to_end_contract. La corrélation est proche de 1. C’est logique : si j’ai un contrat de 12 mois, j’ai souvent 12 mois restants au début.
Ces deux variables apportent la même information. C’est un risque de multicolinéarité. Si une des variables n’est pas significative dans le modèle alors qu’elle devrait l’être, c’est probablement parce que l’autre “capture” tout l’effet explicatif.
Il y a une forte corrélation positive (bleu foncé) entre Frequency_total et Frequency_current Les gens qui viennent souvent en général (Total) sont aussi ceux qui viennent souvent ce mois-ci (Current).
La dernière colonne Churn_num est presque entièrement rouge (corrélation négative). - Lifetime (rouge foncé) : plus on reste, moins on part. - Contract_period (rouge moyen) : les contrats longs protègent. - Age (rouge clair) : l’âge protège. - Avg_class_frequency_current_month (rouge foncé) : c’est la variable la plus fortement corrélée négativement (après Lifetime). C’est bien le meilleur prédicteur.
Taux de censure
# Rappel : Churn = 1 (Evénement), Churn = 0 (Censure)
taux_censure <- 1 - mean(df$Churn_num)
cat("Le taux de censure de notre jeu de données est de :", round(taux_censure * 100, 2), "%\n")## Le taux de censure de notre jeu de données est de : 73.47 %Cela signifie que sur l’ensemble de la base de données, près de trois quarts des clients sont encore abonnés (ou ont quitté l’étude sans qu’on sache quand ils partiront). Seulement 26.53 % ont réellement “churné” (l’événement observé). Ici, il s’agit d’une censure à droite massive.
Création de l’objet de survie et analyse Kaplan-Meier
# 1. Création de l'objet Survival
# Surv(temps, événement)
# Ici : temps = Lifetime, événement = Churn_num (1 = est parti, 0 = est resté/censuré)
surv_obj <- Surv(time = df$Lifetime, event = df$Churn_num)
# 2. Estimateur de Kaplan-Meier (Courbe de survie globale)
fit_km <- survfit(surv_obj ~ 1, data = df)
# 3. Visualisation
ggsurvplot(
fit_km,
data = df,
conf.int = TRUE, # Afficher l'intervalle de confiance
palette = "blue",
xlab = "Temps (Mois)",
ylab = "Probabilité de rétention (survie)",
title = "Courbe de rétention globale des clients",
risk.table = TRUE, # Affiche le nombre de clients à risque sous le graphe
ggtheme = theme_minimal()
)
# On crée le modèle KM spécifiquement pour 'Partner'
fit_partner <- survfit(Surv(Lifetime, Churn_num) ~ Partner, data = df)
# On affiche le graphique
ggsurvplot(
fit_partner,
data = df,
pval = TRUE, # Affiche la p-value (Test Log-Rank)
conf.int = TRUE, # Affiche la zone de confiance
xlab = "Mois",
ylab = "Probabilité de survie",
title = "Rétention : employés partenaires (1) vs standards (0)",
legend.labs = c("Standard", "Partenaire"), # On nomme proprement les groupes
palette = c("#E7B800", "#2E9FDF"),
ggtheme = theme_minimal()
)
fit_group <- survfit(Surv(Lifetime, Churn_num) ~ Group_visits, data = df)
ggsurvplot(
fit_group,
data = df,
pval = TRUE,
conf.int = TRUE,
xlab = "Mois",
title = "Rétention : solo (0) vs groupe (1)",
legend.labs = c("Solo", "Groupe"),
palette = c("#E7B800", "#2E9FDF"),
ggtheme = theme_minimal()
)
fit_promo <- survfit(Surv(Lifetime, Churn_num) ~ Promo_friends, data = df)
ggsurvplot(
fit_promo,
data = df,
pval = TRUE,
conf.int = TRUE,
xlab = "Mois",
title = "Rétention : sans promo (0) vs avec ami (1)",
legend.labs = c("Seul", "Ami"),
palette = c("#E7B800", "#2E9FDF"),
ggtheme = theme_minimal()
)
Courbe de rétention globale des clients
La courbe chute brutalement dès le début. La probabilité de rétention passe de 100% à environ 70% en seulement 3 mois. C’est ici que le taux de churn (attrition) est le plus critique. Si un client doit partir, il part généralement au tout début. C’est souvent lié à une mauvaise expérience d’accueil ou à une baisse de motivation rapide.
La courbe devient presque plate (horizontale) après le 4ème mois. Si vous réussissez à garder un client pendant les 5 premiers mois, il est très peu probable qu’il parte ensuite.
Rétention : employés partenaires (1) vs standards (0)
Les deux courbes sont nettement séparées. La courbe bleue (Partenaire) reste constamment au-dessus de la courbe jaune (Standard). L’écart se creuse dès le 1er mois et reste stable ensuite. On observe qu’au bout de 5 mois (la zone de plateau), environ 80% des clients “Partenaires” sont encore actifs, contre seulement 65% des clients “Standards”. C’est un gain de rétention de +15 points, ce qui est beaucoup. La p-value affichée (p < 0.0001) confirme que cette différence est hautement significative. On peut affirmer avec moins de 0,01% de risque d’erreur que le statut “Partenaire” influence positivement la durée de vie du client. Les programmes avec les entreprises agissent comme un “filet de sécurité”. Les employés d’entreprises partenaires sont des clients plus captifs.
Rétention : solo (0) vs groupe (1)
La courbe bleue (“Groupe”) domine largement la jaune (“Solo”). Au bout de 2 mois seulement, le groupe “Solo” a déjà perdu environ 25% de ses effectifs (la courbe tombe à 0.75), alors que le groupe “Groupe” est encore à 90%. L’intégration sociale (cours collectifs) est un pertinent contre le désabonnement précoce.
En regardant la pente au tout début (0 à 2 mois). La courbe jaune chute beaucoup plus vite que la bleue. Ensuite (après 5 mois), les deux courbes deviennent parallèles et plates. C’est un problème pour le modèle de Cox standard car le “risque relatif” n’est pas constant. Au début, être seul est très dangereux (risque x3 ou x4). Après 6 mois, être seul est moins grave (le risque est plus stable).
Rétention : sans promo (0) vs avec ami (1)
Le programme de parrainage (“Bring a friend”) est un succès. La courbe bleue (Ami) se stabilise autour de 80% de rétention, tandis que la courbe jaune (Seul) chute vers 65%. Quand on s’inscrit avec un ami, abandonner signifie “lâcher” son partenaire de sport. Ce coût psychologique agit comme une barrière à la sortie.
Conclusion Nos analyses de Kaplan-Meier montrent systématiquement que l’isolement est le premier facteur de churn. Que ce soit via un collègue (Partner), un groupe de sport (Group_visits) ou un ami (Promo_friends), tout lien social réduit drastiquement le risque de départ. Le client ne quitte pas une salle de sport, il quitte une communauté.”
Le modèle de Cox
# On exclut 'Churn' (facteur) et 'Churn_num' (target) des variables explicatives
cox_model <- coxph(Surv(Lifetime, Churn_num) ~ gender + Near_Location + Partner +
Promo_friends + Phone + Contract_period + Group_visits +
Age + Avg_additional_charges_total + Month_to_end_contract +
Avg_class_frequency_total + Avg_class_frequency_current_month,
data = df)
# Affichage des résultats avec les Hazard Ratios (exp(coef))
summary(cox_model)## Call:
## coxph(formula = Surv(Lifetime, Churn_num) ~ gender + Near_Location +
## Partner + Promo_friends + Phone + Contract_period + Group_visits +
## Age + Avg_additional_charges_total + Month_to_end_contract +
## Avg_class_frequency_total + Avg_class_frequency_current_month,
## data = df)
##
## n= 4000, number of events= 1061
##
## coef exp(coef) se(coef) z
## gender1 0.0477991 1.0489599 0.0615412 0.777
## Near_Location1 -0.0898846 0.9140367 0.0755558 -1.190
## Partner1 -0.1734925 0.8407235 0.0699024 -2.482
## Promo_friends1 -0.1103211 0.8955466 0.0874261 -1.262
## Phone1 -0.0673488 0.9348690 0.1041484 -0.647
## Contract_period -0.1666851 0.8464661 0.0714718 -2.332
## Group_visits1 -0.2326324 0.7924448 0.0709945 -3.277
## Age -0.1501025 0.8606198 0.0100135 -14.990
## Avg_additional_charges_total -0.0023016 0.9977011 0.0003742 -6.151
## Month_to_end_contract -0.0434645 0.9574666 0.0774865 -0.561
## Avg_class_frequency_total 1.1327537 3.1041928 0.0757737 14.949
## Avg_class_frequency_current_month -1.5847714 0.2049946 0.0692024 -22.901
## Pr(>|z|)
## gender1 0.43734
## Near_Location1 0.23419
## Partner1 0.01307 *
## Promo_friends1 0.20699
## Phone1 0.51785
## Contract_period 0.01969 *
## Group_visits1 0.00105 **
## Age < 2e-16 ***
## Avg_additional_charges_total 7.71e-10 ***
## Month_to_end_contract 0.57485
## Avg_class_frequency_total < 2e-16 ***
## Avg_class_frequency_current_month < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## gender1 1.0490 0.9533 0.9298 1.1834
## Near_Location1 0.9140 1.0940 0.7882 1.0599
## Partner1 0.8407 1.1895 0.7331 0.9642
## Promo_friends1 0.8955 1.1166 0.7545 1.0629
## Phone1 0.9349 1.0697 0.7623 1.1466
## Contract_period 0.8465 1.1814 0.7358 0.9737
## Group_visits1 0.7924 1.2619 0.6895 0.9108
## Age 0.8606 1.1620 0.8439 0.8777
## Avg_additional_charges_total 0.9977 1.0023 0.9970 0.9984
## Month_to_end_contract 0.9575 1.0444 0.8226 1.1145
## Avg_class_frequency_total 3.1042 0.3221 2.6758 3.6012
## Avg_class_frequency_current_month 0.2050 4.8782 0.1790 0.2348
##
## Concordance= 0.883 (se = 0.005 )
## Likelihood ratio test= 2080 on 12 df, p=<2e-16
## Wald test = 1812 on 12 df, p=<2e-16
## Score (logrank) test = 2825 on 12 df, p=<2e-16Les facteurs de fidélisation :
Le nombre moyen de visites par semaine sur le dernier mois observé -> Hazard Ratio = 0.2050 -> p < 2e-16 -> Si un client augmente sa fréquence de visite d’une fois par semaine, son risque de partir baisse considérablement.
L’âge -> Hazard Ratio = 0.86 -> p < 2e-16 -> Chaque année supplémentaire réduit le risque de départ de 14 %. Les clients plus âgés sont plus stables que les jeunes.
Participation à des séances de groupe -> Hazard Ratio = 0.79 -> p = 0.001 -> Participer à des sessions de groupe réduit le risque de 21 %. L’aspect social est un frein au churn.
Venir via une entreprise partenaire -> Hazard Ratio = 0.84 -> p = 0.013 -> Venir via une entreprise partenaire réduit le risque de 16%.
L’engagement contractuel -> Hazard Ratio = 0.85 -> p=0.02 -> Chaque mois supplémentaire dans la durée du contrat initial réduit le risque de 15%.
Les facteurs de risque :
- La fréquence totale historique -> Hazard Ratio = 0.79 -> p < 2e-16 -> Plus la fréquence totale historique est élevée, plus le risque est élevé (x3) -> Cela semble contradictoire avec la fréquence du mois courant. C’est un effet de multicolinéarité comme nous avons vu avec la matrice de corrélation. Quand deux variables sont très corrélées, le modèle peut donner un coefficient positif à l’une et négatif (très fort) à l’autre pour compenser. Cela confirme que la variable Current_Month est la plus pertinente à surveiller.
Le score de Concordance est très bon (0.883) -> le modèle prédit très bien l’ordre des départs
Il faut vérifier l’hypothèse des risques proportionnels. -> Si l’hypothèse est fausse, les coefficients sont peut-être “moyens” mais faux sur la durée. Par exemple, l’effet de l’âge pourrait être très fort au début et nul après 6 mois.
Vérification de l’hypothèse
# Test des résidus de Schoenfeld
test_ph <- cox.zph(cox_model)
# Affichage des résultats du test
print(test_ph)## chisq df p
## gender 0.2469 1 0.619
## Near_Location 2.6520 1 0.103
## Partner 0.0152 1 0.902
## Promo_friends 2.5155 1 0.113
## Phone 3.1856 1 0.074
## Contract_period 5.2731 1 0.022
## Group_visits 5.4884 1 0.019
## Age 18.1374 1 2.1e-05
## Avg_additional_charges_total 5.4543 1 0.020
## Month_to_end_contract 5.9792 1 0.014
## Avg_class_frequency_total 1.6471 1 0.199
## Avg_class_frequency_current_month 41.3962 1 1.2e-10
## GLOBAL 136.1157 12 < 2e-16# Visualisation graphique des violations
ggcoxzph(test_ph,
var = c("Age", "Avg_class_frequency_current_month", "Group_visits", "Contract_period"),
font.main = 12,
font.x = 10,
font.y = 10,
caption = "Résidus de Schoenfeld pour les variables non-proportionnelles")## Warning in splines::ns(temp, df = df, intercept = TRUE): shoving 'interior'
## knots matching boundary knots to inside
Le test global indique : GLOBAL -> p < 2e-16. -> L’hypothèse des risques proportionnels est rejetée. -> Cela signifie que pour certaines variables, le coefficient β (et donc l’impact sur le risque) n’est pas constant dans le temps.
Les variables avec p < 0.05 sont responsables :
Avg_class_frequency_current_month -> p = 1.2e-10 -> Violation extrême. L’impact de la fréquence de visite change probablement au fur et à mesure que l’ancienneté du client augmente.
Age -> p = 2.1e-5 -> L’effet “protecteur” de l’âge varie dans le temps.
Group_visits -> p = 0.019 -> L’effet des visites de groupe n’est pas stable.
Contract_period -> p = 0.022 -> L’impact de la durée du contrat change.
Pour corriger ce problème, nous allons utiliser le modèle de Cox stratifié. -> On prend une variable qui ne respecte pas l’hypothèse (idéalement une variable catégorielle) et on permet au modèle d’avoir une fonction de risque de base différente h0(t) pour chaque groupe de cette variable, tout en gardant les mêmes coefficients pour les autres variables. -> Dans notre cas, Group_visits semble être un bon choix pour la stratification car c’est une variable binaire.
Modèle de Cox stratifié
cox_stratified <- coxph(Surv(Lifetime, Churn_num) ~ gender + Near_Location + Partner +
Promo_friends + Phone + Contract_period +
strata(Group_visits) +
Age + Avg_additional_charges_total + Month_to_end_contract +
Avg_class_frequency_total + Avg_class_frequency_current_month,
data = df)
# Affichage des résultats du modèle stratifié
summary(cox_stratified)## Call:
## coxph(formula = Surv(Lifetime, Churn_num) ~ gender + Near_Location +
## Partner + Promo_friends + Phone + Contract_period + strata(Group_visits) +
## Age + Avg_additional_charges_total + Month_to_end_contract +
## Avg_class_frequency_total + Avg_class_frequency_current_month,
## data = df)
##
## n= 4000, number of events= 1061
##
## coef exp(coef) se(coef) z
## gender1 0.0494898 1.0507349 0.0615436 0.804
## Near_Location1 -0.0944858 0.9098407 0.0755697 -1.250
## Partner1 -0.1763359 0.8383364 0.0699051 -2.523
## Promo_friends1 -0.1049885 0.9003349 0.0873937 -1.201
## Phone1 -0.0522373 0.9491036 0.1042982 -0.501
## Contract_period -0.1656767 0.8473202 0.0715566 -2.315
## Age -0.1505083 0.8602706 0.0100183 -15.023
## Avg_additional_charges_total -0.0023019 0.9977007 0.0003742 -6.152
## Month_to_end_contract -0.0438855 0.9570635 0.0775824 -0.566
## Avg_class_frequency_total 1.1310887 3.0990286 0.0756618 14.949
## Avg_class_frequency_current_month -1.5845463 0.2050408 0.0690953 -22.933
## Pr(>|z|)
## gender1 0.4213
## Near_Location1 0.2112
## Partner1 0.0117 *
## Promo_friends1 0.2296
## Phone1 0.6165
## Contract_period 0.0206 *
## Age < 2e-16 ***
## Avg_additional_charges_total 7.65e-10 ***
## Month_to_end_contract 0.5716
## Avg_class_frequency_total < 2e-16 ***
## Avg_class_frequency_current_month < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## gender1 1.0507 0.9517 0.9313 1.1854
## Near_Location1 0.9098 1.0991 0.7846 1.0551
## Partner1 0.8383 1.1928 0.7310 0.9614
## Promo_friends1 0.9003 1.1107 0.7586 1.0685
## Phone1 0.9491 1.0536 0.7736 1.1644
## Contract_period 0.8473 1.1802 0.7364 0.9749
## Age 0.8603 1.1624 0.8435 0.8773
## Avg_additional_charges_total 0.9977 1.0023 0.9970 0.9984
## Month_to_end_contract 0.9571 1.0449 0.8221 1.1142
## Avg_class_frequency_total 3.0990 0.3227 2.6719 3.5944
## Avg_class_frequency_current_month 0.2050 4.8771 0.1791 0.2348
##
## Concordance= 0.869 (se = 0.005 )
## Likelihood ratio test= 1961 on 11 df, p=<2e-16
## Wald test = 1712 on 11 df, p=<2e-16
## Score (logrank) test = 2581 on 11 df, p=<2e-16# Vérification : Est-ce que cela a amélioré la situation pour les autres variables ?
test_ph_strat <- cox.zph(cox_stratified)
print(test_ph_strat)## chisq df p
## gender 0.2326 1 0.630
## Near_Location 1.8099 1 0.179
## Partner 0.0224 1 0.881
## Promo_friends 1.7274 1 0.189
## Phone 3.6876 1 0.055
## Contract_period 4.2391 1 0.040
## Age 17.3287 1 3.1e-05
## Avg_additional_charges_total 4.9731 1 0.026
## Month_to_end_contract 4.9089 1 0.027
## Avg_class_frequency_total 1.4271 1 0.232
## Avg_class_frequency_current_month 38.9737 1 4.3e-10
## GLOBAL 128.2639 11 < 2e-16Comparaison : le modèle a-t-il changé ?
En regardant les coefficients Hazard Ratio = exp(β) des variables principales entre le modèle 1 (non stratifié) et le modèle 2 (stratifié), nous observons qu’ils sont identiques pour les variables qui nous posaient problème. Donc la stratification par Group_visits a permis de contrôler la forme du risque de base différente pour les groupes, mais cela n’a pas modifié l’estimation de l’impact des autres variables.
Test de Schoenfeld : le problème persiste-t-il ?
En observant le tableau cox.zph :
-> GLOBAL : p < 2e-16 -> Toujours significatif, l’hypothèse est toujours rejetée globalement
-> Les variables responsables Age (p = 3.1e-5) et Avg_class_frequency_current_month (p = 4.3e-10) violent toujours l’hypothèse.
Solution gardée
Nous allons interpréter ces coefficients comme des effets moyens sur la période d’observation, tout en gardant à l’esprit que l’impact de la fréquence de visite est probablement plus critique en début de contrat qu’après une longue période de fidélité.
Validation de la robustesse du modèle (Cross-Validation simple)
# On divise en Train (70%) et Test (30%)
set.seed(123)
train_indices <- sample(1:nrow(df), 0.7 * nrow(df))
train_data <- df[train_indices, ]
test_data <- df[-train_indices, ]
# On ré-entraîne le modèle stratifié sur le Train
cox_train <- coxph(Surv(Lifetime, Churn_num) ~ gender + Near_Location + Partner +
Promo_friends + Phone + Contract_period +
strata(Group_visits) + Age + Avg_additional_charges_total +
Month_to_end_contract + Avg_class_frequency_total +
Avg_class_frequency_current_month,
data = train_data)
# On prédit sur le Test
# Note : c'est technique avec Cox, on regarde souvent le C-index
concordance_test <- concordance(cox_train, newdata = test_data)
print(concordance_test)## Call:
## concordance.coxph(object = cox_train, newdata = test_data)
##
## n= 1200
## Concordance= 0.8699 se= 0.009141
## concordant discordant tied.x tied.y tied.xy
## 1 112298 18330 0 9646 0
## 2 29056 2809 0 1046 0L’indice de concordance (C-index) est l’équivalent de l’AUC pour l’analyse de survie. Cela signifie que si le modèle prend deux clients au hasard, l’un qui part vite et l’autre qui reste longtemps, le modèle prédit correctement l’ordre des événements dans 87% des cas.
L’erreur Standard (se) vaut 0.009, ce qui est très petit. Cela signifie que notre estimation de 0.87 est très précise et stable.
Le test a été effectué sur 1200 clients que le modèle n’avait jamais vus (les 30% de test). Cela prouve qu’il n’y a pas de sur-apprentissage. Le modèle généralisera très bien sur de nouveaux clients.
Prédictions de scénarios (profil à risque VS fidèle)
# 1. Définition des profils
# Profil A : "Le Touriste" (risque élevé)
profil_risque <- data.frame(
gender = factor(1),
Near_Location = factor(0), # Habite loin
Partner = factor(0), # Pas partenaire
Promo_friends = factor(0), # Pas d'ami
Phone = factor(1),
Contract_period = 1, # Contrat court
Group_visits = factor(0), # Sport seul
Age = 25,
Avg_additional_charges_total = 10,
Month_to_end_contract = 1,
Avg_class_frequency_total = 1,
Avg_class_frequency_current_month = 0.5
)
# Profil B : "l'engagé" (profil idéal)
profil_fidele <- data.frame(
gender = factor(1),
Near_Location = factor(1), # Habite près
Partner = factor(1), # Partenaire
Promo_friends = factor(1), # Venu avec ami
Phone = factor(1),
Contract_period = 12, # Contrat long
Group_visits = factor(1), # Sport en groupe
Age = 30,
Avg_additional_charges_total = 200,
Month_to_end_contract = 12,
Avg_class_frequency_total = 3,
Avg_class_frequency_current_month = 3
)
# 2. Calcul des courbes prédites basées sur le modèle stratifié
# Note : survfit gère automatiquement la stratification si les variables sont présentes
fit_pred <- survfit(cox_stratified, newdata = rbind(profil_risque, profil_fidele))
# 3. Visualisation
ggsurvplot(
fit_pred,
data = df,
conf.int = FALSE,
legend.labs = c("Profil À Risque", "Profil Fidèle"),
palette = c("red", "#2E9FDF"),
title = "Prédiction : Comparaison des trajectoires de survie",
xlab = "Mois après inscription",
ylab = "Probabilité de rester client",
ggtheme = theme_minimal()
)
Ce graphique de simulation illustre la capacité discriminante de notre modèle. En comparant un profil “à risque” (courbe rouge) et un profil “engagé” (courbe bleue), nous constatons que le modèle détecte le décrochage dès le premier mois. La chute vertigineuse de la courbe rouge confirme que la combinaison d’une faible fréquence de visite et d’un isolement social (pas de groupe/amis) condamne le client à court terme. C’est sur ces profils que l’action marketing doit être immédiate.
visualiser la “Hazard Function” (le risque instantané) ? -> Non pas besoins, moins en faire mais se concentrer sur la partie théorique -> Le rapport doit ressembler à la 2ème source de méthodolie : théorie, formules…