web-dev-qa-db-ja.com

Rによる区分的回帰：セグメントのプロット

私は54ポイントを持っています。それらは製品の需要と供給を表しています。オファーにブレークポイントがあることを示したいと思います。

まず、x軸（オファー）を並べ替えて、2回表示される値を削除します。 47個の値がありますが、最初と最後の値を削除します（ブレークポイントと見なすのは意味がありません）。休憩の長さは45です。

Break<-(sort(unique(offer))[2:46])

次に、これらの潜在的なブレークポイントのそれぞれについて、モデルを推定し、残余の標準誤差（モデルサマリーオブジェクトの6番目の要素）を「d」に保持します。

d<-numeric(45)
for (i in 1:45) {
model<-lm(demand~(offer<Break[i])*offer + (offer>=Break[i])*offer)
d[i]<-summary(model)[[6]] }

Dをプロットすると、残りの標準誤差が34であることがわかります。これは、「Break [34]」：22.4に対応します。だから私は私の最後のブレークポイントでモデルを書きます：

model<-lm(demand~(offer<22.4)*offer + (offer>=22.4)*offer)

最後に、新しいモデルに満足しています。単純な線形のものよりも大幅に優れています。そして私はそれを描きたい：

plot(demand~offer)
i <- order(offer)
lines(offer[i], predict(model,list(offer))[i])

しかし、警告メッセージがあります。

Warning message:
In predict.lm(model, list(offer)) :
  prediction from a rank-deficient fit may be misleading

そしてもっと重要なのは、私のプロットでは線が本当に奇妙なことです。

My plot with the supposedly two segments, but not joining

これが私のデータです：

demand <- c(1155, 362, 357, 111, 703, 494, 410, 63, 616, 468, 973, 235,
            180, 69, 305, 106, 155, 422, 44, 1008, 225, 321, 1001, 531, 143,
            251, 216, 57, 146, 226, 169, 32, 75, 102, 4, 68, 102, 462, 295,
            196, 50, 739, 287, 226, 706, 127, 85, 234, 153, 4, 373, 54, 81,
            18)
offer <- c(39.3, 23.5, 22.4, 6.1, 35.9, 35.5, 23.2, 9.1, 27.5, 28.6, 41.3,
           16.9, 18.2, 9, 28.6, 12.7, 11.8, 27.9, 21.6, 45.9, 11.4, 16.6,
           40.7, 22.4, 17.4, 14.3, 14.6, 6.6, 10.6, 14.3, 3.4, 5.1, 4.1,
           4.1, 1.7, 7.5, 7.8, 22.6, 8.6, 7.7, 7.8, 34.7, 15.6, 18.5, 35,
           16.5, 11.3, 7.7, 14.8, 2, 12.4, 9.2, 11.8, 3.9)
rplotpiecewise
19
Antonin

ggplot2を使用した簡単なアプローチは次のとおりです。

require(ggplot2)
qplot(offer, demand, group = offer > 22.4, geom = c('point', 'smooth'), 
   method = 'lm', se = F, data = dat)

編集。また、セグメント化された回帰モデルの自動検出と推定をサポートするこのパッケージsegmentedを確認することをお勧めします。

enter image description here

更新：

これは、Rパッケージ segmented を使用してブレークを自動的に検出する例です。

library(segmented)
set.seed(12)
xx <- 1:100
zz <- runif(100)
yy <- 2 + 1.5*pmax(xx - 35, 0) - 1.5*pmax(xx - 70, 0) + 15*pmax(zz - .5, 0) + 
  rnorm(100,0,2)
dati <- data.frame(x = xx, y = yy, z = zz)
out.lm <- lm(y ~ x, data = dati)
o <- segmented(out.lm, seg.Z = ~x, psi = list(x = c(30,60)),
  control = seg.control(display = FALSE)
)
dat2 = data.frame(x = xx, y = broken.line(o)$fit)

library(ggplot2)
ggplot(dati, aes(x = x, y = y)) +
  geom_point() +
  geom_line(data = dat2, color = 'blue')

segmented

24
Ramnath

ヴィンセントはあなたを正しい軌道に乗せています。結果のプロットの線について「奇妙な」唯一のことは、linesがeach連続する点の間に線を引くことです。つまり、単に2つを接続する場合に「ジャンプ」することを意味します。各行の終わり。

そのコネクタが必要ない場合は、lines呼び出しを2つの別々の部分に分割する必要があります。

また、回帰を少し単純化できると思います。これが私がしたことです：

#After reading your data into dat
Break <- 22.4
dat$grp <- dat$offer < Break

#Note the addition of the grp variable makes this a bit easier to read
m <- lm(demand~offer*grp,data = dat)
dat$pred <- predict(m)

plot(dat$offer,dat$demand)
dat <- dat[order(dat$offer),]
with(subset(dat,offer < Break),lines(offer,pred))
with(subset(dat,offer >= Break),lines(offer,pred))

これはこのプロットを生成します：

enter image description here

7
joran

奇妙な線は、単に点がプロットされる順序によるものです。以下の方が見栄えがよいはずです。

i <- order(offer)
lines(offer[i], predict(model,list(offer))[i])

警告は、*文字はlmによって解釈されます。

> lm(demand~(offer<22.4)*offer + (offer>=22.4)*offer)
Call:
lm(formula = demand ~ (offer < 22.4) * offer + (offer >= 22.4) * offer)
Coefficients:
            (Intercept)         offer < 22.4TRUE                    offer  
                -309.46                   356.08                    29.86  
      offer >= 22.4TRUE   offer < 22.4TRUE:offer  offer:offer >= 22.4TRUE  
                     NA                   -20.79                       NA

加えて、 (offer<22.4)*offerは不連続関数です。これは、不連続性の原因です。

以下はあなたが望むものに近いはずです。

model <- lm(
  demand ~ ifelse(offer<22.4,offer-22.4,0) 
           + ifelse(offer>=22.4,offer-22.4,0) )
4
Vincent Zoonekynd