Có vẻ như bạn cũng đang tìm kiếm một câu trả lời từ quan điểm dự đoán, vì vậy tôi đã đưa ra một minh chứng ngắn gọn về hai cách tiếp cận trong R
- Biến một biến thành các yếu tố kích thước bằng nhau.
- Splines khối tự nhiên.
Dưới đây, tôi đã đưa ra mã cho một chức năng sẽ tự động so sánh hai phương thức cho bất kỳ chức năng tín hiệu thực tế nào.
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
Hàm này sẽ tạo ra các tập dữ liệu huấn luyện và kiểm tra nhiễu từ một tín hiệu nhất định, và sau đó khớp một loạt các hồi quy tuyến tính với dữ liệu huấn luyện của hai loại
- Các
cutsmô hình bao gồm dự đoán binned, hình thành bằng cách phân chia phạm vi của dữ liệu vào khoảng thời gian mở một nửa kích thước bằng nhau, và sau đó tạo ra dự đoán nhị phân chỉ mà Interval mỗi điểm đào tạo thuộc.
- Các
splinesmô hình bao gồm một khối mở rộng cơ sở spline tự nhiên, với hải lý cách đều nhau trong suốt phạm vi của dự báo.
Các đối số là
signal: Một hàm một biến đại diện cho sự thật được ước tính.N: Số lượng mẫu để bao gồm trong cả dữ liệu đào tạo và thử nghiệm.noise: Sự kết hợp của nhiễu gaussian ngẫu nhiên để thêm vào tín hiệu huấn luyện và kiểm tra.range: Phạm vi của xdữ liệu đào tạo và kiểm tra , dữ liệu này được tạo thống nhất trong phạm vi này.max_paramters: Số lượng tham số tối đa để ước tính trong một mô hình. Đây vừa là số lượng phân đoạn tối đa trong cutsmô hình, vừa là số lượng nút thắt tối đa trong splinesmô hình.
Lưu ý rằng số lượng tham số ước tính trong splinesmô hình giống với số lượng nút thắt, vì vậy hai mô hình được so sánh khá.
Đối tượng trả về từ hàm có một vài thành phần
signal_plot: Một đồ thị của hàm tín hiệu.data_plot: Một âm mưu phân tán của dữ liệu đào tạo và thử nghiệm.errors_comparison_plot: Một biểu đồ cho thấy sự tiến hóa của tổng tỷ lệ lỗi bình phương cho cả hai mô hình trong một phạm vi số lượng tham số estiamted.
Tôi sẽ trình diễn với hai chức năng tín hiệu. Đầu tiên là một làn sóng tội lỗi với xu hướng tuyến tính gia tăng chồng chất
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
Đây là cách tỷ lệ lỗi phát triển
Ví dụ thứ hai là một hàm hấp dẫn mà tôi giữ xung quanh chỉ cho loại điều này, vẽ nó và xem
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)
Và để giải trí, đây là một hàm tuyến tính nhàm chán
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
Bạn có thể thấy rằng:
- Splines cho hiệu suất thử nghiệm tổng thể tốt hơn khi độ phức tạp của mô hình được điều chỉnh đúng cho cả hai.
- Splines cho hiệu suất thử nghiệm tối ưu với các tham số ước tính ít hơn nhiều .
- Nhìn chung, hiệu suất của splines ổn định hơn nhiều vì số lượng tham số ước tính rất đa dạng.
Vì vậy, spline luôn luôn được ưa thích từ quan điểm dự đoán.
Mã
Đây là mã tôi đã sử dụng để tạo ra các so sánh này. Tôi đã gói tất cả trong một chức năng để bạn có thể dùng thử với các chức năng tín hiệu của riêng bạn. Bạn sẽ cần nhập các thư viện ggplot2và 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
}