Raport 3

Raport3

1 Zadanie 1

2 Wczytanie danych

library(car)

## Ładowanie wymaganego pakietu: carData

library(KernSmooth)

## KernSmooth 2.23 załadowane
## Prawa autorskie M. P. Wand 1997-2009

library(tidyverse)

## Warning: pakiet 'ggplot2' został zbudowany w wersji R 4.3.3

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.0
## ✔ purrr     1.0.2

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ✖ dplyr::recode() masks car::recode()
## ✖ purrr::some()   masks car::some()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

data("Prestige")

3 Usuwamy brakujące dane

Prestige <- na.omit(Prestige)

4 Wykres relacji między dochodem a prestiżem

ggplot(Prestige)+
  geom_point(aes(x=income, y=prestige))

Związek raczej nieliniowy. Do pewnego poziomu można się doszukiwac liniowości, ta granica jest przy zarobkach około 10k USD.

5 1. Kernel smoothing

library(KernSmooth)

5.1 Porównanie pasm (brandwith)

5.2 1.1 Brandwith=1

ker1 <- locpoly(Prestige$prestige, Prestige$income,
                degree = 0, bandwidth = 1) %>% 
  as_tibble()

ggplot(Prestige) +
  geom_point(aes(x = prestige, y = income)) +
  geom_line(data = ker1, aes(x = x, y = y), col = 'red') +
  ggtitle("Kernel smoothing - szerokość pasma równa 1")

5.3 1.2 Brandwith=4

ker4 <- locpoly(Prestige$prestige, Prestige$income,
                degree = 0, bandwidth = 4) %>% 
  as_tibble()

ggplot(Prestige) +
  geom_point(aes(x = prestige, y = income)) +
  geom_line(data = ker4, aes(x = x, y = y), col = 'green') +
  ggtitle("Kernel smoothing - szerokość pasma równa 4")

6 2. Model Loess kwadratowy

loess_model <- loess(income ~ prestige, data = Prestige, span = 0.75, degree = 2)

ggplot(Prestige, aes(x = prestige, y = income)) +
  geom_point(color = "blue", size = 2) +  
  geom_smooth(method = "loess", span = 0.75, color = "red", fill = "darkgreen", alpha = 0.2) +
  ggtitle("LOESS (degree = 2) z przedzałem ufności") +
  xlab("Prestiż") +
  ylab("Dochód") +
  theme_minimal()

## `geom_smooth()` using formula = 'y ~ x'

Bardzo dużo obserwacji odstaję od przedziału ufności. Szczególnie powyżej 10k USD.

7 3. Sploty interpolujące

spline_model <- 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

spline_data <- data.frame(x = spline_model$x, y = spline_model$y)


ggplot(Prestige, aes(x = income, y = prestige)) +
  geom_point(color = "blue", size = 2) +  
  geom_line(data = spline_data, aes(x = x, y = y), color = "red", size = 1.2) + 
  ggtitle("Sploty interpolujące (lambda wybrana przez CV)") +
  xlab("Dochód") +
  ylab("Prestiż") +
  theme_minimal()

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

8 4. Sploty naturalne

library(splines)

nat1 <- lm(income ~ ns(prestige, df = 6), data = Prestige)
nat2 <- lm(income ~ ns(prestige, df = 12), data = Prestige)

ggplot(Prestige) +
  geom_point(aes(x = prestige, y = income)) +
  ggtitle("Naturalne sploty, 6 df (niebieski) i 12 df (czerwony)") +
  geom_line(aes(x = prestige, y = fitted(nat1)), col = 'darkblue', size = 0.7) + 
  geom_line(aes(x = prestige, y = fitted(nat2)), col = 'pink', size = 0.7) +
  xlab("Prestiż") +
  ylab("Dochód") +
  theme_minimal()

ggplot(Prestige) +
    geom_point(aes(x=prestige,y=income)) +
    geom_smooth(aes(x=prestige,y=income), method='gam',
      formula = y ~ s(x,k=12))

9 Zadanie 2

10 1. Kernel smoothing

library(MASS)

## 
## Dołączanie pakietu: 'MASS'

## Następujący obiekt został zakryty z 'package:dplyr':
## 
##     select

data(mycycle)

## Warning in data(mycycle): zbiór danych 'mycycle' nie został znaleziony

ggplot(mcycle)+
  geom_point(aes(x=times,y=accel))

10.1 Porównanie pasm (brandwith)

10.2 1.1 Brandwith=1

ker1 <- locpoly(mcycle$times, mcycle$accel,
                degree = 0, bandwidth = 1) %>% as.tibble

## Warning: `as.tibble()` was deprecated in tibble 2.0.0.
## ℹ Please use `as_tibble()` instead.
## ℹ The signature and semantics have changed, see `?as_tibble`.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

ggplot(mcycle) +
  geom_point(aes(x=times, y=accel)) +
  geom_line(data = ker1, aes(x = x, y = y), col = 'red') +
  ggtitle("Kernel smoothing - szerokość pasma równa 1")

10.3 1.2 Brandwith=4

ker4 <- locpoly(mcycle$times, mcycle$accel,
                degree = 0, bandwidth = 4) %>% as.tibble

ggplot(mcycle) +
  geom_point(aes(x = times, y = accel)) +
  geom_line(data = ker4, aes(x = x, y = y), col = 'green') +
  ggtitle("Kernel smoothing - szerokość pasma równa 4")

Szerokość pasma równa 1 lepiej odwzorowuje, szczególnie to widać przy łapaniu górek i dołków.

11 2. Model Loess kwadratowy

loess_model2 <- loess(accel ~ times, data = mcycle, span = 0.25, degree = 2)

ggplot(mcycle, aes(x = times, y = accel)) +
  geom_point(color = "blue", size = 2) +  
  geom_smooth(method = "loess", span = 0.75, color = "red", fill = "darkgreen", alpha = 0.2) +
  ggtitle("LOESS (degree = 2) z przedziałem ufności") +
  xlab("Czas (ms)") +
  ylab("Przyspieszenie (g)") +
  theme_minimal()

## `geom_smooth()` using formula = 'y ~ x'

ggplot(mcycle, aes(x = times, y = accel)) +
  geom_point(color = "blue", size = 2) +  
  geom_smooth(method = "loess", span = 0.25, color = "red", fill = "darkgreen", alpha = 0.2) +
  ggtitle("LOESS (degree = 2) z przedziałem ufności") +
  xlab("Czas (ms)") +
  ylab("Przyspieszenie (g)") +
  theme_minimal()

## `geom_smooth()` using formula = 'y ~ x'

Span=0,75 bardzo słabo odwzorowywał zmienne, więc słusznym była zmiana na span=0,25.

12 3. Sploty interpolujące

spline <- smooth.spline(mcycle$times, mcycle$accel, cv=TRUE)

## Warning in smooth.spline(mcycle$times, mcycle$accel, cv = TRUE): krzyżowa
## walidacja z nieunikalnymi wartościami 'x' wydaje się wątpliwa

spline_data2 <- data.frame(x = spline$x, y = spline$y)


ggplot(mcycle, aes(x = times, y = accel)) +
  geom_point(color = "blue", size = 2) +  
  geom_line(data = spline_data2, aes(x = x, y = y), color = "red", size = 1.2) + 
  ggtitle("Sploty interpolujące (lambda wybrana przez CV)") +
  xlab("Czas (ms)") +
  ylab("Przyspieszenie (g)") +
  theme_minimal()

13 4. Sploty naturalne

library(splines)

nat3 <- lm(accel ~ ns(times, df = 6), data = mcycle)
nat4 <- lm(accel ~ ns(times, df = 12), data = mcycle)


ggplot(mcycle) +
  geom_point(aes(x = times, y = accel)) +
  ggtitle("Naturalne sploty, 6 df (niebieski) i 12 df (czerwony)") +
  geom_line(aes(x = times, y = fitted(nat3)), col = 'darkblue', size = 0.7) + 
  geom_line(aes(x = times, y = fitted(nat4)), col = 'pink', size = 0.7) +
  xlab("Czas (ms)") +
  ylab("Przyspieszenie (g)") +
  theme_minimal()