Bạn có thể làm điều này bằng cách sử dụng các spline bị phạt với các ràng buộc đơn điệu thông qua các hàm mono.con()
và pcls()
hàm trong gói mgcv . Có một chút khó khăn phải làm vì các chức năng này không thân thiện với người dùng gam()
, nhưng các bước được hiển thị bên dưới, chủ yếu dựa trên ví dụ từ ?pcls
, được sửa đổi cho phù hợp với dữ liệu mẫu bạn đã cung cấp:
df <- data.frame(x=1:10, y=c(100,41,22,10,6,7,2,1,3,1))
## Set up the size of the basis functions/number of knots
k <- 5
## This fits the unconstrained model but gets us smoothness parameters that
## that we will need later
unc <- gam(y ~ s(x, k = k, bs = "cr"), data = df)
## This creates the cubic spline basis functions of `x`
## It returns an object containing the penalty matrix for the spline
## among other things; see ?smooth.construct for description of each
## element in the returned object
sm <- smoothCon(s(x, k = k, bs = "cr"), df, knots = NULL)[[1]]
## This gets the constraint matrix and constraint vector that imposes
## linear constraints to enforce montonicity on a cubic regression spline
## the key thing you need to change is `up`.
## `up = TRUE` == increasing function
## `up = FALSE` == decreasing function (as per your example)
## `xp` is a vector of knot locations that we get back from smoothCon
F <- mono.con(sm$xp, up = FALSE) # get constraints: up = FALSE == Decreasing constraint!
Bây giờ chúng ta cần điền vào đối tượng được chuyển qua để pcls()
chứa các chi tiết của mô hình bị ràng buộc bị phạt mà chúng ta muốn phù hợp
## Fill in G, the object pcsl needs to fit; this is just what `pcls` says it needs:
## X is the model matrix (of the basis functions)
## C is the identifiability constraints - no constraints needed here
## for the single smooth
## sp are the smoothness parameters from the unconstrained GAM
## p/xp are the knot locations again, but negated for a decreasing function
## y is the response data
## w are weights and this is fancy code for a vector of 1s of length(y)
G <- list(X = sm$X, C = matrix(0,0,0), sp = unc$sp,
p = -sm$xp, # note the - here! This is for decreasing fits!
y = df$y,
w = df$y*0+1)
G$Ain <- F$A # the monotonicity constraint matrix
G$bin <- F$b # the monotonicity constraint vector, both from mono.con
G$S <- sm$S # the penalty matrix for the cubic spline
G$off <- 0 # location of offsets in the penalty matrix
Bây giờ chúng ta cuối cùng cũng có thể làm được việc lắp
## Do the constrained fit
p <- pcls(G) # fit spline (using s.p. from unconstrained fit)
p
chứa một vectơ hệ số cho các hàm cơ sở tương ứng với spline. Để hình dung spline được trang bị, chúng ta có thể dự đoán từ mô hình tại 100 vị trí trong phạm vi x. Chúng tôi thực hiện 100 giá trị để có được một dòng mượt mà trên cốt truyện.
## predict at 100 locations over range of x - get a smooth line on the plot
newx <- with(df, data.frame(x = seq(min(x), max(x), length = 100)))
Để tạo các giá trị dự đoán mà chúng tôi sử dụng Predict.matrix()
, nó tạo ra một ma trận sao cho khi nhiều hệ số p
mang lại các giá trị dự đoán từ mô hình được trang bị:
fv <- Predict.matrix(sm, newx) %*% p
newx <- transform(newx, yhat = fv[,1])
plot(y ~ x, data = df, pch = 16)
lines(yhat ~ x, data = newx, col = "red")
Điều này tạo ra:
Tôi sẽ để nó cho bạn lấy dữ liệu ở dạng gọn gàng để vẽ đồ thị với ggplot ...
Bạn có thể buộc phù hợp chặt chẽ hơn (để trả lời một phần câu hỏi của bạn về việc có điểm phù hợp mượt mà hơn với điểm dữ liệu đầu tiên) bằng cách tăng kích thước của hàm cơ sở của x
. Ví dụ: đặt k
bằng 8
( k <- 8
) và chạy lại mã ở trên mà chúng tôi nhận được
Bạn không thể đẩy k
cao hơn nhiều cho những dữ liệu này và bạn phải cẩn thận về việc phù hợp quá mức; tất cả pcls()
đang làm là giải quyết vấn đề bình phương tối thiểu bị phạt do các ràng buộc và các hàm cơ sở được cung cấp, nó không thực hiện lựa chọn độ trơn cho bạn - không phải tôi biết ...)
Nếu bạn muốn nội suy, thì hãy xem hàm R cơ sở có các hàm ?splinefun
Hermite và các khối vuông với các ràng buộc đơn điệu. Trong trường hợp này, bạn không thể sử dụng điều này tuy nhiên dữ liệu không hoàn toàn đơn điệu.
plot(y~x,data=df); f=fitted( glm( y~ns(x,df=4), data=df,family=quasipoisson)); lines(df$x,f)