Öngörülü bir bakış açısıyla aynı zamanda bir cevap da aradığınıza benziyor, ben de R’de iki yaklaşımın kısa bir gösterimini hazırladım.
- Bir değişkeni eşit boyutlu faktörlere bölmek.
- Doğal kübik spline.
Aşağıda, verilen herhangi bir gerçek sinyal fonksiyonu için iki yöntemi otomatik olarak karşılaştıracak bir fonksiyonun kodunu verdim.
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Bu fonksiyon gürültülü bir eğitim ve belirli bir sinyalden veri setlerini test eder ve ardından iki tip eğitim verisine bir dizi doğrusal regresyon sağlar.
cutsModel eşit boyutlu yarı açık aralıklar halinde veri aralığı segmentlere ve ki burada her bir eğitim noktası ait aralığın gösteren ikili belirleyicilerini oluşturarak meydana binned yordayıcılarını içerir.splinesDüğümler eşit prediktörü aralığı boyunca aralıklı olan bir model, bir doğal kübik eğri taban genişleme içerir.
Argümanlar
signal: Tahmini yapılacak gerçeği temsil eden değişken bir fonksiyon.N: Hem eğitim hem de test verilerine dahil edilecek örneklerin sayısı.noise: Eğitim ve test sinyaline eklenecek olan rastgele gauss gürültüsünün duyuruları.range: Eğitim ve test xverilerinin menzili, bu aralıkta homojen bir şekilde üretilen veriler.max_paramters: Bir modelde tahmin edilecek maksimum parametre sayısı. Bu, hem cutsmodeldeki maksimum segment sayısı hem de modeldeki maksimum düğüm sayısıdır splines.
splinesModelde tahmin edilen parametre sayısının düğüm sayısıyla aynı olduğunu, bu nedenle iki modelin oldukça karşılaştırıldığını unutmayın.
İşlevden dönen nesne birkaç bileşene sahiptir
signal_plot: Sinyal fonksiyonunun bir grafiği.data_plot: Eğitim ve test verilerinin bir dağılım grafiği.errors_comparison_plot: Her iki model için de karelenmiş hata oranlarının toplamının, tahmin edilen parametrelerin sayısı aralığındaki gelişimini gösteren bir çizim.
İki sinyal fonksiyonu ile göstereceğim. Birincisi, üst üste binen artan doğrusal eğilim ile günah dalgası
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
İşte hata oranlarının nasıl geliştiği
İkinci örnek, sadece bu tür bir şey için etrafta tuttuğum, onu çizip gördüğüm bir saçma işlevidir.
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)
Ve eğlence için, işte sıkıcı bir doğrusal fonksiyon
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Görebilirsin:
- Splines, model karmaşıklığı her ikisi için de uygun şekilde ayarlandığında genel olarak daha iyi bir genel test performansı sunar.
- Splines, daha az tahmini parametrelerle en iyi test performansını sunar .
- Genel olarak, spline'ların performansı, tahmini parametrelerin sayısı değiştiğinden çok daha kararlıdır.
Bu nedenle, eğri çizgiler her zaman öngörücü bir açıdan tercih edilmelidir.
kod
İşte bu karşılaştırmaları üretmek için kullandığım kod. Hepsini bir fonksiyona sardım, böylece kendi sinyal fonksiyonlarınızla deneyebilirsiniz. ggplot2Ve splinesR kütüphanelerini içe aktarmanız gerekecektir .
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
}