Sepertinya Anda juga mencari jawaban dari sudut pandang prediktif, jadi saya mengumpulkan demonstrasi pendek dari dua pendekatan dalam R
- Membagi variabel menjadi faktor ukuran yang sama.
- Splines kubik alami.
Di bawah ini, saya telah memberikan kode untuk fungsi yang akan membandingkan kedua metode secara otomatis untuk fungsi sinyal yang sebenarnya diberikan
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Fungsi ini akan membuat pelatihan yang berisik dan menguji set data dari sinyal yang diberikan, dan kemudian menyesuaikan serangkaian regresi linier dengan data pelatihan dari dua jenis
- The
cutsModel termasuk prediktor binned, yang dibentuk oleh segmentasi kisaran data ke dalam interval terbuka setengah ukuran yang sama, dan kemudian menciptakan prediktor biner yang menunjukkan ke mana interval setiap titik pelatihan milik.
- The
splinesModel termasuk kubik dasar spline ekspansi alam, dengan knot sama spasi sepanjang rentang dari prediktor tersebut.
Argumennya adalah
signal: Fungsi satu variabel yang mewakili kebenaran untuk diperkirakan.N: Jumlah sampel untuk dimasukkan dalam pelatihan dan data pengujian.noise: Jumlah kebisingan gaussian acak untuk menambah sinyal pelatihan dan pengujian.range: Kisaran data pelatihan dan pengujian x, data ini dihasilkan secara seragam dalam kisaran ini.max_paramters: Jumlah maksimum parameter untuk diestimasi dalam suatu model. Ini adalah jumlah maksimum segmen dalam cutsmodel, dan jumlah maksimum simpul dalam splinesmodel.
Perhatikan bahwa jumlah parameter yang diestimasi dalam splinesmodel adalah sama dengan jumlah simpul, sehingga kedua model tersebut cukup dibandingkan.
Objek kembali dari fungsi memiliki beberapa komponen
signal_plot: Sebidang fungsi sinyal.data_plot: Sebaran plot pelatihan dan data pengujian.errors_comparison_plot: Plot yang menunjukkan evolusi jumlah tingkat kesalahan kuadrat untuk kedua model pada rentang jumlah parameter yang diukur.
Saya akan menunjukkan dengan dua fungsi sinyal. Yang pertama adalah gelombang dosa dengan tren linier yang meningkat ditumpangkan
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
Inilah cara tingkat kesalahan berkembang
Contoh kedua adalah fungsi gila yang saya simpan hanya untuk hal semacam ini, plot dan lihat
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)
Dan untuk bersenang-senang, ini adalah fungsi linear yang membosankan
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Anda dapat melihat bahwa:
- Splines memberikan kinerja tes keseluruhan yang lebih baik secara keseluruhan ketika kompleksitas model disetel dengan benar untuk keduanya.
- Splines memberikan kinerja tes optimal dengan parameter estimasi yang jauh lebih sedikit .
- Secara keseluruhan kinerja splines jauh lebih stabil karena jumlah parameter yang diestimasikan bervariasi.
Jadi splines selalu lebih disukai dari sudut pandang prediktif.
Kode
Berikut kode yang saya gunakan untuk membuat perbandingan ini. Saya telah membungkus semuanya dalam suatu fungsi sehingga Anda dapat mencobanya dengan fungsi sinyal Anda sendiri. Anda harus mengimpor perpustakaan ggplot2dan 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
}