On dirait que vous cherchez également une réponse d'un point de vue prédictif, j'ai donc préparé une courte démonstration de deux approches dans R
- Regroupement d'une variable en facteurs de taille égale.
- Splines cubiques naturelles.
Ci-dessous, j'ai donné le code d'une fonction qui comparera automatiquement les deux méthodes pour une fonction de signal vraie donnée
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Cette fonction créera des ensembles de données d'apprentissage et de test bruyants à partir d'un signal donné, puis adaptera une série de régressions linéaires aux données d'entraînement de deux types
- Le
cutsmodèle comprend des prédicteurs regroupés, formés en segmentant la plage des données en intervalles à moitié ouverts de taille égale, puis en créant des prédicteurs binaires indiquant à quel intervalle chaque point d'apprentissage appartient.
- Le
splinesmodèle comprend une expansion de base de spline cubique naturelle, avec des nœuds également espacés dans toute la plage du prédicteur.
Les arguments sont
signal: Une fonction à une variable représentant la vérité à estimer.N: Le nombre d'échantillons à inclure dans les données de formation et de test.noise: La quantité de bruit gaussien aléatoire à ajouter au signal d'entraînement et de test.range: La plage des xdonnées de formation et de test , données générées uniformément dans cette plage.max_paramters: Le nombre maximum de paramètres à estimer dans un modèle. Il s'agit à la fois du nombre maximal de segments dans le cutsmodèle et du nombre maximal de nœuds dans le splinesmodèle.
Notez que le nombre de paramètres estimés dans le splinesmodèle est le même que le nombre de nœuds, donc les deux modèles sont assez comparés.
L'objet de retour de la fonction a quelques composants
signal_plot: Un tracé de la fonction du signal.data_plot: Un nuage de points des données de formation et de test.errors_comparison_plot: Un graphique montrant l'évolution de la somme des taux d'erreur au carré pour les deux modèles sur une plage du nombre de paramètres estimés.
Je vais démontrer avec deux fonctions de signal. Le premier est une onde sinueuse avec une tendance linéaire croissante superposée
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
Voici comment évoluent les taux d'erreur
Le deuxième exemple est une fonction de noix que je garde juste pour ce genre de chose, tracez-la et voyez
true_signal_weird <- function(x) {
x*x*x*(x-1) + 2*(1/(1+exp(-.5*(x-.5)))) - 3.5*(x > .2)*(x < .5)*(x - .2)*(x - .5)
}
obj <- test_cuts_vs_splines(true_signal_weird, 250, .05)
Et pour le plaisir, voici une fonction linéaire ennuyeuse
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Tu peux voir ça:
- Les splines donnent globalement de meilleures performances de test lorsque la complexité du modèle est correctement réglée pour les deux.
- Les splines offrent des performances de test optimales avec beaucoup moins de paramètres estimés .
- Globalement, les performances des splines sont beaucoup plus stables car le nombre de paramètres estimés varie.
Les splines sont donc toujours à privilégier d'un point de vue prédictif.
Code
Voici le code que j'ai utilisé pour produire ces comparaisons. J'ai tout enveloppé dans une fonction pour que vous puissiez l'essayer avec vos propres fonctions de signal. Vous devrez importer les bibliothèques ggplot2and splinesR.
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154) {
if(max_parameters < 8) {
stop("Please pass max_parameters >= 8, otherwise the plots look kinda bad.")
}
out_obj <- list()
set.seed(seed)
x_train <- runif(N, range[1], range[2])
x_test <- runif(N, range[1], range[2])
y_train <- signal(x_train) + rnorm(N, 0, noise)
y_test <- signal(x_test) + rnorm(N, 0, noise)
# A plot of the true signals
df <- data.frame(
x = seq(range[1], range[2], length.out = 100)
)
df$y <- signal(df$x)
out_obj$signal_plot <- ggplot(data = df) +
geom_line(aes(x = x, y = y)) +
labs(title = "True Signal")
# A plot of the training and testing data
df <- data.frame(
x = c(x_train, x_test),
y = c(y_train, y_test),
id = c(rep("train", N), rep("test", N))
)
out_obj$data_plot <- ggplot(data = df) +
geom_point(aes(x=x, y=y)) +
facet_wrap(~ id) +
labs(title = "Training and Testing Data")
#----- lm with various groupings -------------
models_with_groupings <- list()
train_errors_cuts <- rep(NULL, length(models_with_groupings))
test_errors_cuts <- rep(NULL, length(models_with_groupings))
for (n_groups in 3:max_parameters) {
cut_points <- seq(range[1], range[2], length.out = n_groups + 1)
x_train_factor <- cut(x_train, cut_points)
factor_train_data <- data.frame(x = x_train_factor, y = y_train)
models_with_groupings[[n_groups]] <- lm(y ~ x, data = factor_train_data)
# Training error rate
train_preds <- predict(models_with_groupings[[n_groups]], factor_train_data)
soses <- (1/N) * sum( (y_train - train_preds)**2)
train_errors_cuts[n_groups - 2] <- soses
# Testing error rate
x_test_factor <- cut(x_test, cut_points)
factor_test_data <- data.frame(x = x_test_factor, y = y_test)
test_preds <- predict(models_with_groupings[[n_groups]], factor_test_data)
soses <- (1/N) * sum( (y_test - test_preds)**2)
test_errors_cuts[n_groups - 2] <- soses
}
# We are overfitting
error_df_cuts <- data.frame(
x = rep(3:max_parameters, 2),
e = c(train_errors_cuts, test_errors_cuts),
id = c(rep("train", length(train_errors_cuts)),
rep("test", length(test_errors_cuts))),
type = "cuts"
)
out_obj$errors_cuts_plot <- ggplot(data = error_df_cuts) +
geom_line(aes(x = x, y = e)) +
facet_wrap(~ id) +
labs(title = "Error Rates with Grouping Transformations",
x = ("Number of Estimated Parameters"),
y = ("Average Squared Error"))
#----- lm with natural splines -------------
models_with_splines <- list()
train_errors_splines <- rep(NULL, length(models_with_groupings))
test_errors_splines <- rep(NULL, length(models_with_groupings))
for (deg_freedom in 3:max_parameters) {
knots <- seq(range[1], range[2], length.out = deg_freedom + 1)[2:deg_freedom]
train_data <- data.frame(x = x_train, y = y_train)
models_with_splines[[deg_freedom]] <- lm(y ~ ns(x, knots=knots), data = train_data)
# Training error rate
train_preds <- predict(models_with_splines[[deg_freedom]], train_data)
soses <- (1/N) * sum( (y_train - train_preds)**2)
train_errors_splines[deg_freedom - 2] <- soses
# Testing error rate
test_data <- data.frame(x = x_test, y = y_test)
test_preds <- predict(models_with_splines[[deg_freedom]], test_data)
soses <- (1/N) * sum( (y_test - test_preds)**2)
test_errors_splines[deg_freedom - 2] <- soses
}
error_df_splines <- data.frame(
x = rep(3:max_parameters, 2),
e = c(train_errors_splines, test_errors_splines),
id = c(rep("train", length(train_errors_splines)),
rep("test", length(test_errors_splines))),
type = "splines"
)
out_obj$errors_splines_plot <- ggplot(data = error_df_splines) +
geom_line(aes(x = x, y = e)) +
facet_wrap(~ id) +
labs(title = "Error Rates with Natural Cubic Spline Transformations",
x = ("Number of Estimated Parameters"),
y = ("Average Squared Error"))
error_df <- rbind(error_df_cuts, error_df_splines)
out_obj$error_df <- error_df
# The training error for the first cut model is always an outlier, and
# messes up the y range of the plots.
y_lower_bound <- min(c(train_errors_cuts, train_errors_splines))
y_upper_bound = train_errors_cuts[2]
out_obj$errors_comparison_plot <- ggplot(data = error_df) +
geom_line(aes(x = x, y = e)) +
facet_wrap(~ id*type) +
scale_y_continuous(limits = c(y_lower_bound, y_upper_bound)) +
labs(
title = ("Binning vs. Natural Splines"),
x = ("Number of Estimated Parameters"),
y = ("Average Squared Error"))
out_obj
}