예측 관점에서 답을 찾고있는 것처럼 보이므로 R에서 두 가지 접근법에 대한 간단한 데모를 모았습니다.
- 변수를 같은 크기의 요인으로 묶기.
- 천연 큐빅 스플라인.
아래에는 주어진 실제 신호 함수에 대해 두 가지 방법을 자동으로 비교하는 함수에 대한 코드가 있습니다.
test_cuts_vs_splines <- function(signal, N, noise,
range=c(0, 1),
max_parameters=50,
seed=154)
이 함수는 주어진 신호에서 시끄러운 훈련 및 테스트 데이터 세트를 생성 한 다음 일련의 선형 회귀 분석을 두 가지 유형의 훈련 데이터에 맞 춥니 다.
- 이
cuts모형에는 데이터 범위를 동일한 크기의 반 열린 간격으로 분할 한 다음 각 트레이닝 포인트가 속하는 간격을 나타내는 이진 예측자를 만들어 비닝 예측자를 포함합니다.
- 이
splines모형에는 자연 입방 스플라인 기반 확장이 포함되어 있으며, 예측 변수 범위 전체에 매듭이 동일하게 배치되어 있습니다.
논쟁은
signal: 추정 할 진실을 나타내는 하나의 변수 함수.N: 교육 및 테스트 데이터에 포함 할 샘플 수입니다.noise: 훈련 및 테스트 신호에 추가 할 임의 가우스 노이즈의 범위.range: 훈련 및 시험 x데이터 의 범위 ,이 범위 내에서 균일하게 생성 된 데이터.max_paramters: 모형에서 추정 할 최대 매개 변수 수입니다. cuts모델 의 최대 세그먼트 수 와 모델의 최대 매듭 수입니다 splines.
splines모형 에서 추정 된 매개 변수 의 수는 노트 수와 동일하므로 두 모형이 상당히 비교됩니다.
함수의 반환 객체에는 몇 가지 구성 요소가 있습니다.
signal_plot: 신호 기능의 플롯.data_plot: 교육 및 테스트 데이터의 산점도.errors_comparison_plot: 추정 된 매개 변수 수 범위에서 두 모델의 제곱 오차 비율의 진화를 보여주는 그림.
두 가지 신호 기능으로 시연하겠습니다. 첫 번째는 증가하는 선형 추세가 중첩 된 사인파입니다.
true_signal_sin <- function(x) {
x + 1.5*sin(3*2*pi*x)
}
obj <- test_cuts_vs_splines(true_signal_sin, 250, 1)
오류율이 어떻게 진화 하는가
두 번째 예는 이런 종류의 것만을 위해 유지하는 너트 티 함수입니다.
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)
그리고 재미를 위해 여기에 지루한 선형 함수가 있습니다
obj <- test_cuts_vs_splines(function(x) {x}, 250, .2)
당신은 그것을 볼 수 있습니다 :
- 스플라인은 모델 복잡성이 두 가지 모두에 맞게 적절히 조정될 때 전반적인 테스트 성능을 전반적으로 향상시킵니다.
- 스플라인은 훨씬 적은 추정 매개 변수로 최적의 테스트 성능을 제공 합니다.
- 추정 된 파라미터의 수가 변함에 따라 스플라인의 전반적인 성능은 훨씬 안정적입니다.
따라서 스플라인은 항상 예측 관점에서 선호됩니다.
암호
이러한 비교를 수행하는 데 사용한 코드는 다음과 같습니다. 나는 당신이 당신의 자신의 신호 기능으로 그것을 시험해 볼 수 있도록 모든 기능을 래핑했습니다. ggplot2및 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
}