2017-01-10 7 views
0

Я пытаюсь подобрать данные в кусочно-линейную модель. Сегментированный пакет работает очень хорошо, за исключением того, что я не могу найти способ применить ограничения к коэффициентам. Мне нужно ограничить наклоны линейных сегментов диапазоном значений (например, 0-0.1 для сегмента 1 и> 0,5 для сегмента 2). Вот пример без ограничений. Благодарю.коэффициенты сжатия для сегментированной кусочно-линейной подгонки

library(segmented) 

#generate data for fit 
c <- 1 
m <- 0.47 #slope of 2nd line 
d <- 4 
n<- 30 
sd <- 0.2 
b <- c-m*d 
x<- runif(n,0,10) 
y<- ifelse(x<=d,c+rnorm(n,0,sd),m*x+b+rnorm(n,0,sd)) #piecewise data for fit 
plot(x,y) 

lin.mod <- lm(y~x) 
segmented.mod <- segmented(lin.mod, seg.Z = ~x, psi=6) 
summary(segmented.mod) 
plot(segmented.mod, add=T) 

ответ

0

Это может быть не элегантный способ сделать это, но мне удалось решить проблему с constrOptim.

#generate data for fit 
set.seed(2) 
c <- 1 
m <- 0.47 #slope of 2nd line 
d <- 4 
n<- 30 
sd <- 0.2 
b <- c-m*d 
x<- runif(n,0,10) 
y<- ifelse(x<=d,c+rnorm(n,0,sd),m*x+b+rnorm(n,0,sd)) #piecewise data for fit 
plot(x,y) 

#define slope value constriants 
l.slope.min <- 0 
l.slope.max <- 0.1 
r.slope.min <- 0.5 
r.slope.max <- 0.99 

# par[1] - transition point for pieces. 
# par[2] - slope of left piece. 
# par[3] - intercept of left piece. 
# par[4] - slope of right piece. 
# the intercept of the right piece is par[1]*(par[2]-par[4])+par[3] 
f <- function (x,par) {ifelse(x<par[1],par[2]*x+par[3],par[4]*x+(par[1]*(par[2]-par[4])+par[3]))} 
r2 <- function(data,par) {with(data, sum(((y-f(x,par))^2)))} 

#to set up the constraint matrix and vector follow instructions in constrOptim documentation 
ui <- cbind(c(0,0,0,0),c(-1,1,0,0),c(0,0,0,0),c(0,0,1,-1)) 
ci <- c(-l.slope.max,l.slope.min,r.slope.min,-r.slope.max) 
ci <- ci - 1e-6 #displace startinng point from boundry 
par <- c(5, 0.05,1.2, 0.8) #initial parameters 

(ui %*% par)-ci >=0 #confirm that starting values are in the feasible region 

result <-constrOptim(theta =par, f=r2 , grad= NULL, ui=ui, ci=ci,data = data.frame(x,y)) 

abline(a = result$par[3], b = result$par[2], col = "red") 
abline(a = result$par[1]*(result$par[2]-result$par[4])+result$par[3], b = result$par[4], col = "blue") 

 Смежные вопросы

  • Нет связанных вопросов^_^