Sembra che tu stia anche cercando una risposta dal punto di vista predittivo, quindi ho messo insieme una breve dimostrazione di due approcci in R
- Binning di una variabile in fattori di uguali dimensioni.
- Spline cubiche naturali.
Di seguito, ho fornito il codice per una funzione che confronterà automaticamente i due metodi per una data funzione di segnale reale
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Questa funzione creerà set di dati di addestramento e test rumorosi da un determinato segnale, quindi inserirà una serie di regressioni lineari sui dati di allenamento di due tipi
- Il
cutsmodello include predittori integrati, formati segmentando l'intervallo di dati in intervalli di mezza apertura di uguale dimensione e quindi creando predittori binari che indicano a quale intervallo appartiene ciascun punto di allenamento.
- Il
splinesmodello include un'espansione di base spline cubica naturale, con nodi equidistanti su tutta la gamma del predittore.
Gli argomenti sono
signal: Una funzione con una variabile che rappresenta la verità da stimare.N: Il numero di campioni da includere sia nei dati di addestramento che di test.noise: L'abbondanza di rumore gaussiano casuale da aggiungere al segnale di allenamento e test.range: La gamma dei xdati di addestramento e test , i dati sono generati in modo uniforme all'interno di questo intervallo.max_paramters: Il numero massimo di parametri da stimare in un modello. Questo è sia il numero massimo di segmenti nel cutsmodello sia il numero massimo di nodi nel splinesmodello.
Si noti che il numero di parametri stimati nel splinesmodello è uguale al numero di nodi, quindi i due modelli sono equamente confrontati.
L'oggetto return dalla funzione ha alcuni componenti
signal_plot: Un grafico della funzione del segnale.data_plot: Un diagramma a dispersione dei dati di addestramento e test.errors_comparison_plot: Un diagramma che mostra l'evoluzione della somma del tasso di errore al quadrato per entrambi i modelli su un intervallo del numero di parametri stimati.
Dimostrerò con due funzioni di segnale. La prima è un'onda sin con una tendenza lineare crescente sovrapposta
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
Ecco come si evolvono i tassi di errore
Il secondo esempio è una funzione folle che tengo in giro solo per questo genere di cose, trama e vedo
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)
E per divertimento, ecco una noiosa funzione lineare
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Potete vederlo:
- Le spline offrono prestazioni complessive di prova complessivamente migliori quando la complessità del modello è sintonizzata correttamente per entrambi.
- Le spline offrono prestazioni di prova ottimali con molti meno parametri stimati .
- Nel complesso, le prestazioni delle spline sono molto più stabili poiché il numero di parametri stimati è variato.
Quindi le spline devono essere sempre preferite da un punto di vista predittivo.
Codice
Ecco il codice che ho usato per produrre questi confronti. Ho racchiuso tutto in una funzione in modo che tu possa provarlo con le tue funzioni di segnale. Dovrai importare le librerie ggplot2e 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
}