Parece que también está buscando una respuesta desde un punto de vista predictivo, por lo que preparé una breve demostración de dos enfoques en R
- Binning una variable en factores de igual tamaño.
- Splines cúbicos naturales.
A continuación, he dado el código para una función que comparará los dos métodos automáticamente para cualquier función de señal verdadera
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Esta función creará conjuntos de datos de entrenamiento y prueba ruidosos a partir de una señal dada, y luego ajustará una serie de regresiones lineales a los datos de entrenamiento de dos tipos
- El
cutsmodelo incluye predictores agrupados, formados segmentando el rango de datos en intervalos semiabiertos de igual tamaño, y luego creando predictores binarios que indican a qué intervalo pertenece cada punto de entrenamiento.
- El
splinesmodelo incluye una expansión de base de spline cúbica natural, con nudos igualmente espaciados en todo el rango del predictor.
Los argumentos son
signal: Una función de una variable que representa la verdad a estimar.N: El número de muestras a incluir tanto en los datos de entrenamiento como de prueba.noise: La cantidad de ruido gaussiano aleatorio para agregar a la señal de entrenamiento y prueba.range: El rango de los xdatos de entrenamiento y prueba , datos que se generan de manera uniforme dentro de este rango.max_paramters: El número máximo de parámetros para estimar en un modelo. Este es el número máximo de segmentos en el cutsmodelo y el número máximo de nudos en el splinesmodelo.
Tenga en cuenta que el número de parámetros estimados en el splinesmodelo es el mismo que el número de nudos, por lo que los dos modelos se comparan bastante.
El objeto de retorno de la función tiene algunos componentes.
signal_plot: Un gráfico de la función de señal.data_plot: Un diagrama de dispersión de los datos de entrenamiento y prueba.errors_comparison_plot: Un gráfico que muestra la evolución de la suma de la tasa de error al cuadrado para ambos modelos en un rango del número de parámetros estimados.
Lo demostraré con dos funciones de señal. La primera es una ola de pecado con una tendencia lineal creciente superpuesta
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
Así es como evolucionan las tasas de error
El segundo ejemplo es una función de nuez que mantengo solo para este tipo de cosas, trazarla y ver
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)
Y por diversión, aquí hay una aburrida función lineal
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Puedes ver eso:
- Las splines brindan un mejor rendimiento general de la prueba cuando la complejidad del modelo se ajusta adecuadamente para ambos.
- Las splines ofrecen un rendimiento de prueba óptimo con muchos menos parámetros estimados .
- En general, el rendimiento de las splines es mucho más estable ya que el número de parámetros estimados varía.
Por lo tanto, las splines siempre se deben preferir desde un punto de vista predictivo.
Código
Aquí está el código que usé para producir estas comparaciones. Lo he incluido todo en una función para que pueda probarlo con sus propias funciones de señal. Deberá importar las bibliotecas ggplot2y 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
}