[英]Rough thin-plate spline fitting (thin-plate spline interpolation) in R with mgcv
背景
我試圖在《 統計學習入門 》一書中復制圖2.6 :
粗糙的薄板樣條曲線適合圖2.3中的收入數據。 這種擬合使訓練數據的錯誤為零。
到目前為止,我嘗試了什么?
我試圖復制前面的圖2.5,它是平滑的薄板樣條曲線擬合,不確定是否成功。
income_2 <- read.csv("http://www-bcf.usc.edu/~gareth/ISL/Income2.csv")
library(mgcv)
model1 <- gam(Income ~ te(Education, Seniority, bs=c("tp", "tp")), data = income_2)
x <- range(income_2$Education)
x <- seq(x[1], x[2], length.out=30)
y <- range(income_2$Seniority)
y <- seq(y[1], y[2], length.out=30)
z <- outer(x,y,
function(Education,Seniority)
predict(model1, data.frame(Education,Seniority)))
p <- persp(x,y,z, theta=30, phi=30,
col="yellow",expand = 0.5,shade = 0.2,
xlab="Education", ylab="Seniority", zlab="Income")
obs <- trans3d(income_2$Education, income_2$Seniority,income_2$Income,p)
pred <- trans3d(income_2$Education, income_2$Seniority,fitted(model1),p)
points(obs, col="red",pch=16)
segments(obs$x, obs$y, pred$x, pred$y)
雙重問題
bs="tp"
,文檔中說:“它們是薄板樣條線的降階版本,並使用薄板樣條線罰分。” income_2 <- structure(list(Education = c(21.5862068965517, 18.2758620689655,
12.0689655172414, 17.0344827586207, 19.9310344827586, 18.2758620689655,
19.9310344827586, 21.1724137931034, 20.3448275862069, 10, 13.7241379310345,
18.6896551724138, 11.6551724137931, 16.6206896551724, 10, 20.3448275862069,
14.1379310344828, 16.6206896551724, 16.6206896551724, 20.3448275862069,
18.2758620689655, 14.551724137931, 17.448275862069, 10.4137931034483,
21.5862068965517, 11.2413793103448, 19.9310344827586, 11.6551724137931,
12.0689655172414, 17.0344827586207), Seniority = c(113.103448275862,
119.310344827586, 100.689655172414, 187.586206896552, 20, 26.2068965517241,
150.344827586207, 82.0689655172414, 88.2758620689655, 113.103448275862,
51.0344827586207, 144.137931034483, 20, 94.4827586206897, 187.586206896552,
94.4827586206897, 20, 44.8275862068966, 175.172413793103, 187.586206896552,
100.689655172414, 137.931034482759, 94.4827586206897, 32.4137931034483,
20, 44.8275862068966, 168.965517241379, 57.2413793103448, 32.4137931034483,
106.896551724138), Income = c(99.9171726114381, 92.579134855529,
34.6787271520874, 78.7028062353695, 68.0099216471551, 71.5044853814318,
87.9704669939115, 79.8110298331255, 90.00632710858, 45.6555294997364,
31.9138079371295, 96.2829968022869, 27.9825049000603, 66.601792415137,
41.5319924201478, 89.00070081522, 28.8163007592387, 57.6816942573605,
70.1050960424457, 98.8340115435447, 74.7046991976891, 53.5321056283034,
72.0789236655191, 18.5706650327685, 78.8057842852386, 21.388561306174,
90.8140351180409, 22.6361626208955, 17.613593041445, 74.6109601985289
)), .Names = c("Education", "Seniority", "Income"), row.names = c(NA,
-30L), class = "data.frame")
library(mgcv)
首先,您可以將s(Education, Seniority, bs = 'tp')
用於二元薄板樣條曲線,而不必使用張量積構造。 薄板樣條線在任何尺寸上都是明確定義的。
其次, mgcv
不會進行回歸而不是插值,因此,如果不進行調整,就無法使擬合的樣條曲線遍歷所有點。 薄板樣條的調整包括:
k
設置為唯一采樣點的確切數量(如果您有超過2000個唯一數據位置,則為xt
來禁用bs = 'tp'
后面的低秩逼近; sp = 0
禁用樣條曲線的懲罰。 您的數據集income_2
中唯一采樣位置的數量為
xt <- unique(income_2[c("Education", "Seniority")])
nrow(xt)
#[1] 30
因為30小於2000,所以我們可以將k = 30
設置k = 30
不需要將xt
傳遞給s(, bs = 'tp')
。
interpolation_model <- gam(Income ~ s(Education, Seniority, k = 30, sp = 0),
data = income_2)
interpolation_model$residuals
# [1] 2.131628e-13 2.728484e-12 4.561684e-12 1.264766e-12 3.495870e-12
# [6] 4.177991e-12 -1.023182e-12 1.193712e-12 2.231104e-12 6.878054e-12
#[11] 6.309619e-12 6.679102e-13 7.574386e-12 3.637979e-12 4.227729e-12
#[16] 1.790568e-12 4.376943e-12 5.130119e-12 8.242296e-13 -6.536993e-13
#[21] 2.771117e-12 1.811884e-12 3.495870e-12 9.141132e-12 2.117417e-12
#[26] 7.243983e-12 -3.979039e-13 6.352252e-12 6.203038e-12 3.652190e-12
現在您看到所有殘差均為零。
您還可以查找直接執行薄板樣條插值的其他程序包。
薄板花鍵是各向同性的/徑向的,如果變量的比例不同,請小心!
感謝您的解釋和解決我的問題。 您知道為什么花鍵表面看起來起伏更大,而脊卻更少嗎?
因為您的兩個變量的比例差異很大。 您要首先標准化兩個變量,然后擬合薄板樣條。
## this is how your original data look like on the 2D domain
with(income_2, plot(Education, Seniority, asp = 1))
## let's scale it
xt_scaled <- scale(xt)
dat <- data.frame(xt_scaled, Income = income_2$Income)
with(dat, plot(Education, Seniority, asp = 1))
## fit a model on scaled data
interpolation_model <- gam(Income ~ s(Education, Seniority, k = 30, sp = 0),
data = dat)
## grid on the transformed space
x <- range(dat$Education)
x <- seq(x[1], x[2], length.out=30)
y <- range(dat$Seniority)
y <- seq(y[1], y[2], length.out=30)
## prediction on the transformed space
newdat <- expand.grid(Education = x, Seniority = y)
z <- matrix(predict(interpolation_model, newdat), nrow = length(x))
現在要生成圖,我們想將網格反向轉換為其原始比例。 注意,這不需要轉換預測值。
## back transform the grid
scaled_center <- attr(xt_scaled, "scaled:center")
#Education Seniority
# 16.38621 93.86207
scaled_scale <- attr(xt_scaled, "scaled:scale")
#Education Seniority
# 3.810622 55.715623
xx <- x * scaled_scale[1] + scaled_center[1]
yy <- y * scaled_scale[2] + scaled_center[2]
## use `xx`, `yy` and `z`
p <- persp(xx, yy, z, theta = 30, phi = 30,
col = "yellow",expand = 0.5, shade = 0.2,
xlab = "Education", ylab = "Seniority", zlab = "Income")
obs <- trans3d(income_2$Education, income_2$Seniority, income_2$Income, p)
pred <- trans3d(income_2$Education, income_2$Seniority, fitted(interpolation_model), p)
points(obs, col="red",pch=16)
segments(obs$x, obs$y, pred$x, pred$y)
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.