Raport 3 - regresja nieparametryczna

Regresja nieparametryczna jest używana, gdy chcemy dopasować model do danych bez konieczności zakładania konkretnego kształtu zależności między zmiennymi. Jest bardziej elastyczna od regresji parametrycznej, bo nie zakłada konkretnego kształtu fukcji.

Zadanie 1

Do zbadania zależności między prestiżem a dochodem wykorzystaj metody regresji nieparametrycznej.

library(car)
data('Prestige')
library(ggplot2)
library(KernSmooth)
library(dplyr)
library(tibble)
library(stats)
library(splines)

Dane “Prestige” z pakietu car

income - średni dochód urzędników, w dolarach, w 1971 r.

prestige - wynik prestiżu Pineo-Portera dla zawodu, z badania społecznego przeprowadzonego w połowie lat 1960

Wizualizacja zależności pomiędzy dochodem a posiadanym prestiżem

ggplot(Prestige, aes(income, prestige))+
  geom_point()+
  geom_vline(xintercept = 10000, color = "red")+
  labs(title='Wykres rozrzutu dochodu i prestiżu')

Wniosek: Widzimy, że powiązanie między zmiennymi jest nieliniowe. Dla osób z dochodem poniżej 10000$, poziom prestiżu definitywnie wzrasta wraz ze wzrostem dochodu, natomiast dalszy wzrost tych dochodów, nie ma już tak dużego wpływu na zmianę prestiżu, który jest dla osób bogatszych na podobnym , wysokim poziomie.

Regresja lokalna

locpoly stosuje metodę lokalnej regresji wielomianowej, w której dla każdego punktu danych dopasowywany jest wielomian

fit <- locpoly(Prestige$income, Prestige$prestige, 
               degree=0, bandwidth=7, gridsize=1000) 
fit <- tibble(x = fit$x, y = fit$y)

ggplot(Prestige) +
  geom_point(aes(x=income, y=prestige)) +
  geom_line(data=fit, aes(x=x, y=y), col='#53868B')

Dla tego przypadku, szerokość pasma wygładzenia musiał być dość duży, aby w ogóle można było narysować regresje. Dodatkowo zwiększony gridsize powoduje gęstrzy wykres. Nie jest to metoda idealna dla posiadanych danych w zadaniu - zdecydowanie zbyt szczegółowy.

Loess - lokalnie kwadratowy (degree = 2)

loess() wykonuje dopasowanie lokalne, gdzie dla każdego punktu w danych dopasowywany jest wielomian, uwzględniający jedynie najbliższe sąsiednie punkty

fit2 <- loess(prestige~income, span=0.20, degree=2,
  family="gaussian", Prestige)
fit3 <- loess(prestige~income, span=0.40, degree=2,
  family="gaussian", Prestige)
ggplot(Prestige)+
  geom_point(aes(x=income,y=prestige))+
  geom_line(aes(x=income,y=fitted(fit2)), col='#AB82FF')+
  geom_line(aes(x=income,y=fitted(fit3)), col='#7CCD7C')+
  labs(title='Loess: szerokość pasma =0.2 i =0.4')

Wniosek: Szeroskość pasma = 0.2 wydaje się byc zbyt szczegółowo dopasowana. Wyższa wartość szerokości pasma (0.4) dostarcza lepszą, gładszą krzywą.

fit4 <- loess(prestige~income, span=0.40, degree=2,
  family="symmetric", Prestige)

ggplot(Prestige)+
  geom_point(aes(x=income,y=prestige))+
  geom_line(aes(x=income,y=fitted(fit3)), col='#7CCD7C')+
  geom_line(aes(x=income,y=fitted(fit4)), col='#FF83FA')+
  labs(title='Loess: rodzina rozkładów: gaussian i symmetric')

Wniosek: Family = “symmetric” zredukował wpływ wartości odstających, przez co w mniejszym stopniu ingerują w kształt trendu. Najlepiej widać różnicę dla zarobków w okolicach 5000$.

fit5 <- loess(prestige~income, span=0.40, degree=1, family="symmetric", Prestige)

ggplot(Prestige)+
  geom_point(aes(x=income,y=prestige))+ 
  geom_line(aes(x=income,y=fitted(fit4)), col='#FF83FA')+ 
  geom_line(aes(x=income,y=fitted(fit5)), col='#FFA500')+ 
  labs(title='Loess: rząd wielomianu: 1(pomarańcz) i 2(róż)')

Wniosek: Różnica pomiędzy zastosowaniem wielominau kwadratowego a liniowego jest zauważana. Lepiej wygładzona jest regresja lokalna korzystająca z wielomiany 1 stopnia.

Regresja spline’owa - sploty interpolujące

smr <- smooth.spline(Prestige$income, Prestige$prestige,cv=TRUE)
## Warning in smooth.spline(Prestige$income, Prestige$prestige, cv = TRUE):
## krzyżowa walidacja z nieunikalnymi wartościami 'x' wydaje się wątpliwa
smr2 <- smooth.spline(Prestige$income, Prestige$prestige, spar=0.9)

smr <- data.frame(x=smr$x,y=smr$y)
smr2 <- data.frame(x=smr2$x,y=smr2$y)

ggplot(Prestige)+
  geom_point(aes(x=income,y=prestige))+
  geom_line(data=smr, aes(x=x, y=y), col='blue')+
  geom_line(data=smr2, aes(x=x, y=y), col='lightblue')+
  labs(title='Sploty interpolujące ')

Wniosek: Ciemniejszą niebieską linią została narysowana fukcja o optymalnej wartości parametru wygładzenia lambda. Dzięki temu dopasowanie jest optymalne pod kątem minimalizacji błędu.

Sploty regresyjne

Sploty naturalne to specjalna forma splotów, które na końcach zakresu danych przyjmują kształt linii prostych, co zapobiega nadmiernemu dopasowaniu na krańcach zakresu danych.

fit6 <- lm(prestige ~ ns(income, df=6), Prestige)
fit7 <- lm(prestige ~ ns(income, df=3), Prestige)
ggplot(Prestige) +
  geom_point(aes(x=income,y=prestige))+ 
  geom_line(aes(x=income,y=fitted(fit6)), col='#00C5CD')+
  geom_line(aes(x=income,y=fitted(fit7)), col='#CD6889')+
  labs(title='Sploty naturalne, df = 6 i df = 3')

Wniosek: Im więcej stopni swoboty, tym spolt regresyjny będzie bardziej szczegółowy.

Ponieważ splajny regresyjne używają lokalnych modeli liniowych, możemy łatwo znaleźć błędy standardowe dla dopasowanych wartości. Połączone razem, tworzą one punktowy przedział ufności. Automatycznie tworzone przy użyciu geom_smooth.

ggplot(Prestige) +
    geom_point(aes(x=income,y=prestige)) +
    geom_smooth(aes(x=income,y=prestige), method='gam', formula = y ~ s(x,k=6))+
  labs(title='Sploty z przedziałem ufności')

Parametr k=6 wskazuje maksymalną liczbę stopni swobody. Kontroluje, jak elastyczne jest dopasowanie: większa liczba stopni swobody oznacza bardziej szczegółowe dopasowanie.

Zadanie 2

Do zbadania zależności między czasem a przyspieszeniem wykorzystaj metody regresji nieparametrycznej.

Dane ‘mcycle’ z pakietu MASS

library(MASS)
data(mcycle)

times - czas w minisekundach po wypadku

accel - obserwowane przyśpieszenia głowy w g

Wizualizacja zależność pomiędzy czasem a przyśpieszeniem

ggplot(mcycle, aes(times, accel))+
  geom_point()+
  labs(title='Wykres rozrzutu dochodu i prestiżu')+
  xlab('Czas (ms)')+
  ylab('Przyśpieszenie (g)')

Przyspieszenie jest stabilne od 0-15 ms, spada od ok. 15-20 ms, rośnie od 20-30 ms, spada od 30-40 ms, a następnie zaczyna się stabilizować.

Regresja lokalna

  1. Lockpol
fit8 <- locpoly(mcycle$times, mcycle$accel, 
               degree=0, bandwidth=1) 
fit9 <- locpoly(mcycle$times, mcycle$accel, 
               degree=0, bandwidth=2)

fit8 <- tibble(x = fit8$x, y = fit8$y)
fit9 <- tibble(x = fit9$x, y = fit9$y)


ggplot(mcycle) +
  geom_point(aes(x=times, y=accel)) +
  geom_line(data=fit8, aes(x=x, y=y), col='#A2CD5A')+
  geom_line(data=fit9, aes(x=x, y=y), col='#6E8B3D')+
  labs(title='Regresja lokalna locpoly z różną szerokością pasma')

Wniosek: Zwiększając szerokość pasma, zmniejszamy szczególowość funkcji.

Możemy dalej porównać fukcje regresji lokalnej lockpoly o szerokości pasma równej 2 (zaznaczona ciemno-zielonym kolorem) o różnym stopniu wielomianu funkcji.

fit9 <- locpoly(mcycle$times, mcycle$accel, 
               degree=0, bandwidth=2)
fit10 <- locpoly(mcycle$times, mcycle$accel, 
               degree=1, bandwidth=2) 
fit11 <- locpoly(mcycle$times, mcycle$accel, 
               degree=2, bandwidth=2) 

fit9 <- tibble(x = fit9$x, y = fit9$y)
fit10 <- tibble(x = fit10$x, y = fit10$y)
fit11 <- tibble(x = fit11$x, y = fit11$y)



ggplot(mcycle) +
  geom_point(aes(x=times, y=accel)) +
  geom_line(data=fit9, aes(x=x, y=y), col='#6E8B3D')+
  geom_line(data=fit10, aes(x=x, y=y), col='#FF7F00')+
  geom_line(data=fit11, aes(x=x, y=y), col='#5F9EA0')+
  labs(title='Regresja lokalna locpoly z różnym st. wielomianu')

Wniosek: Zwiększając stopień wiolomianu, delikatnie zwiększamy szczegółowość funcji. Kolorem niebieskim zazaczono regresje kwadratową, pomarańczowym regresje liniową, a zielonym średnią ruchomą.

  1. Loess - lokalnie kwadratowy (degree = 2)
fit12 <- loess(accel~times, span=0.3, degree=2,
  family="gaussian", mcycle)
fit13 <- loess(accel~times, span=0.6, degree=2,
  family="gaussian", mcycle)
ggplot(mcycle)+
  geom_point(aes(x=times,y=accel))+
  geom_line(aes(x=times,y=fitted(fit12)), col='#AB82FF')+
  geom_line(aes(x=times,y=fitted(fit13)), col='#7CCD7C')+
  labs(title='Loess: szerokość pasma 30% i 60%')

Wniosek: Zwiększając szerokość pasma, zmniejszamy szczegółowość funcji. W tym przypadku span = 0.8 (80% pokrycia danych) błędnie zaokrągliło początek funkcji regresji i wykazało trend malejący dla czasu 30 - 60 ms. Parametr span odpowiada za poziom wygładzenia fukcji, wartości bliższe 1 dają mniej precyzyjne dopasowanie, a dokładniejsze dają wartości bliższe 0.

ggplot(mcycle) +
    geom_point(aes(x=times,y=accel)) +
    geom_smooth(aes(x=times,y=accel), method='loess',span=0.30, col='#AB82FF')+
  labs(title='Loess: szerokość pasma 30% z przedziałem ufności')
## `geom_smooth()` using formula = 'y ~ x'

Sploty naturalne

fit14 <- lm(accel ~ ns(times, df=6), mcycle)
fit15 <- lm(accel ~ ns(times, df=10), mcycle)
ggplot(mcycle) +
  geom_point(aes(x=times,y=accel))+ 
  geom_line(aes(x=times,y=fitted(fit14)), col='#00C5CD')+
  geom_line(aes(x=times,y=fitted(fit15)), col='#CD6889')+
  labs(title='Sploty naturalne, df = 6 i df = 10')

Wniosek: W tym przykładzie mamy sploty naturalne z 6 i 10 st. swobody, które regulują liczbę węzłów, czyli połączonych odcinków wielomianów. Im więcej stopni swobody zastosujemy dla fukcji, tym bardziej szczegłówą otrzymamy tą funcję.