Sklep rowerowy
Zuzanna Jasińska (202283), Kacper Bareja (206756), Adam Lewandowski (180355), Jan Gasik (190446)
Wstęp
Klienci pewnego sklepu rowerowego zostali poproszeni o wypełnienie ankiety, gdzie podawali dane na swój temat (m.in. status cywilny, przychód, liczbę dzieci, płeć, wiek) oraz czy kupili rower. Celem analizy jest znalezienie czynników, które decydują o tym, czy rower zostaje zakupiony.
Dane
Zbiór danych w pliku sklep_rowerowy.csv zawiera szczegółowe informacje na temat 1000 użytkowników z różnych środowisk oraz finalną decyzję o kupnie roweru. Zbiór ten może posiadać braki, wartości odstające oraz inne niedoskonałości.
Repozytorium na GitHub
Prace zostały wykonane z użyciem systemu kontroli wersji Git, a jako zdalne miejsce do przechowania repozytorium wykorzystano platformę GitHub.
Link do repozytorium: https://github.com/Leeewyyy/SklepRowerowy
Użyte biblioteki
Podczas analizy użyto następujących bibliotek:
library(gt)
library(naniar)
library(tidyverse)
library(VIM)
library(ggplot2)
library(kableExtra)
library(dplyr)
library(tidyr)
library(corrplot)
library(ggstatsplot)Wczytanie i wizualizacja danych
W tabeli pokazano 10 pierwszych wierszy zbioru danych. Można zauważyć, że w zbiorze występują brakujące dane.
data <- read.csv("sklep_rowerowy.csv")
gt(head(data,10))| ID | Marital.Status | Gender | Income | Children | Education | Occupation | Home.Owner | Cars | Commute.Distance | Region | Age | Purchased.Bike |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 12496 | Married | Female | 40000 | 1 | Bachelors | Skilled Manual | Yes | 0 | 0-1 Miles | Europe | 42 | No |
| 24107 | Married | Male | 30000 | 3 | Partial College | Clerical | Yes | 1 | 0-1 Miles | Europe | 43 | No |
| 14177 | Married | Male | 80000 | 5 | Partial College | Professional | No | 2 | 2-5 Miles | Europe | 60 | No |
| 24381 | Single | 70000 | 0 | Bachelors | Professional | Yes | 1 | 5-10 Miles | Pacific | 41 | Yes | |
| 25597 | Single | Male | 30000 | 0 | Bachelors | Clerical | No | 0 | 0-1 Miles | Europe | 36 | Yes |
| 13507 | Married | Female | 10000 | 2 | Partial College | Manual | Yes | 0 | 1-2 Miles | Europe | 50 | No |
| 27974 | Single | Male | 160000 | 2 | High School | Management | 4 | 0-1 Miles | Pacific | 33 | Yes | |
| 19364 | Married | Male | 40000 | 1 | Bachelors | Skilled Manual | Yes | 0 | 0-1 Miles | Europe | 43 | Yes |
| 22155 | Male | 20000 | 2 | Partial High School | Clerical | Yes | 2 | 5-10 Miles | Pacific | 58 | No | |
| 19280 | Married | Male | NA | 2 | Partial College | Manual | Yes | 1 | 0-1 Miles | Europe | NA | Yes |
Data Cleansing, Wrangling
Początkowa liczba i proporcje NA
Na początku sprawdzono ile występuje wartości NA i wartości pełnych w zbiorze danych. Dodatkowo za pomocą funkcji is.special sprawdzono czy w zbiorze danych występują inne wartości specjalne. Jeśli takowe znaleziono, zastąpiono je wartościami NA.
n_miss(data)## [1] 31n_complete(data)## [1] 12969is.special <- function(x){
if(is.numeric(x)) !is.finite(x) else is.na(x)
}sapply(data, is.special)for(n in colnames(data)){
is.na(data[[n]]) <- is.special(data[[n]])
}
summary(data)## ID Marital.Status Gender Income
## Min. :11000 Length:1000 Length:1000 Min. : 10000
## 1st Qu.:15291 Class :character Class :character 1st Qu.: 30000
## Median :19744 Mode :character Mode :character Median : 60000
## Mean :19966 Mean : 56268
## 3rd Qu.:24471 3rd Qu.: 70000
## Max. :29447 Max. :170000
## NA's :6
## Children Education Occupation Home.Owner
## Min. :0.00 Length:1000 Length:1000 Length:1000
## 1st Qu.:0.00 Class :character Class :character Class :character
## Median :2.00 Mode :character Mode :character Mode :character
## Mean :1.91
## 3rd Qu.:3.00
## Max. :5.00
## NA's :8
## Cars Commute.Distance Region Age
## Min. :0.000 Length:1000 Length:1000 Min. :25.00
## 1st Qu.:1.000 Class :character Class :character 1st Qu.:35.00
## Median :1.000 Mode :character Mode :character Median :43.00
## Mean :1.455 Mean :44.18
## 3rd Qu.:2.000 3rd Qu.:52.00
## Max. :4.000 Max. :89.00
## NA's :9 NA's :8
## Purchased.Bike
## Length:1000
## Class :character
## Mode :character
##
##
##
## Znaleziono 31 wartości NA. W celu głębszej analizy stworzono tabelę podsumowującą braki dla wszystkich zmiennych.
miss_var_summary(data)## # A tibble: 13 × 3
## variable n_miss pct_miss
## <chr> <int> <num>
## 1 Cars 9 0.9
## 2 Children 8 0.8
## 3 Age 8 0.8
## 4 Income 6 0.6
## 5 ID 0 0
## 6 Marital.Status 0 0
## 7 Gender 0 0
## 8 Education 0 0
## 9 Occupation 0 0
## 10 Home.Owner 0 0
## 11 Commute.Distance 0 0
## 12 Region 0 0
## 13 Purchased.Bike 0 0Brakujące dane znajdują się w kolumnach: cars, children, age oraz income. W powyższej tabeli możemy zauważyć dokładną ilość braków dla każdej zmiennej oraz procentowy skład tych braków w stosunku do całego zbioru danych.
Warto również dowiedzieć się ile wierszy zawiera wartości NA. Poniższy kod tworzy tabelę pokazującą rozkład ilości NA na poszczególne zmienne oraz ich procent w stosunku do całego zbioru.
miss_case_table(data)## # A tibble: 3 × 3
## n_miss_in_case n_cases pct_cases
## <int> <int> <dbl>
## 1 0 971 97.1
## 2 1 27 2.7
## 3 2 2 0.297.1% wierszy jest kompletna. 27 wierszy ma jedną wartość NA. Dwa braki mają 2 wiersze.
Wizualizacja brakujących wartości
vis_miss(data)
Wizualizacja całego zbioru danych wykazała 0.2% zbioru jako brakujące dane.
gg_miss_var(data)
Powyżej jeszcze wykres słupkowy pokazujący liczbę brakujących wartości dla każdej zmiennej.
gg_miss_upset(data, nsets=12)
Najwięcej danych odstających (bezwzględnie) widnieje dla zmiennych Cars_NA, Children_NA i Age_NA (tj. poziome słupki). Opis poszczególnych kolumn wygląda następująco:
- kolumna 1: jest dokładnie 9 obserwacji, w których zmienna ma wartość NA
- kolumna 2: jest dokładnie 7 obserwacji, w których zmienna Children ma wartość NA
- kolumna 3: jest dokładnie 6 obserwacji, w których zmienna Age ma wartość NA
- kolumna 4: jest dokładnie 5 obserwacji, w których zmienna Income ma wartość NA
- kolumna 5: jest dokładnie 1 obserwacja, w której zmienna Income, jak i Age ma wartość NA
- kolumna 6: jest dokładnie 1 obserwacja, w których zmienna Age, jak i Chindren ma wartość 1
Zależności między brakami danych w zmiennych
Podejmiemy teraz próbę analizy zależności tych braków między sobą. Zacznijmy od zbadania zależności zmiennej cars. Wyznaczymy wykres zależności w stosunku do zmiennych Income oraz Age.
ggplot(data = data, aes(x = Cars, y = Income)) +
geom_point() +
geom_miss_point() +
scale_color_manual(values = c("darkorange","cyan4")) +
theme_minimal()## Warning: Removed 15 rows containing missing values or values outside the scale range
## (`geom_point()`).
Gdyby nie jedna obserwacja można by przyjąć, że brak danych w zmeinnej Cars zależy od zmiennej Income (osoby, które podały niski Income nie podają zmiennej Cars). Jednak mamy jedną obserwację, dla której zmienna Income ma wysoką wartość, a Cars pozostaje NA. Dla najwyższych wartości Cars (3 i 4) nie zauważamy wartości NA w zmiennej Income, możemy więc przyjąć, że istnieje pewna zależność między tymi dwoma zmiennymi.
ggplot(data = data, aes(x = Cars, y = Age)) +
geom_point() +
geom_miss_point() +
scale_color_manual(values = c("darkorange","cyan4")) +
theme_minimal()## Warning: Removed 17 rows containing missing values or values outside the scale range
## (`geom_point()`).
Dla zmeinnej Age sytuacja wygląda tak samo - osoby z różnym wiekiem nie podały ilości samochodów, jak i osoby z różną ilością samocodów nie podały wieku.
Pod analizę poddamy teraz zmienną Age i jej zależność ze zmiennymi Children i Income.
ggplot(data = data, aes(x = Age, y = Children)) +
geom_point() +
geom_miss_point() +
scale_color_manual(values = c("darkorange","cyan4")) +
theme_minimal()## Warning: Removed 15 rows containing missing values or values outside the scale range
## (`geom_point()`).
ggplot(data = data, aes(x = Age, y = Income)) +
geom_point() +
geom_miss_point() +
scale_color_manual(values = c("darkorange","cyan4")) +
theme_minimal()## Warning: Removed 13 rows containing missing values or values outside the scale range
## (`geom_point()`).
Dla zmiennych Age i Children nie zaobserwowaliśmy żadnych zależności. Można tylko zauważyć, że istnieje jedna obserwacja dla których obie zmienne mają wartość NA. Inaczej sytuacja wygląda dla zmiennych Age i Income. Możemy tutaj zaobserwować, że tylko osoby z niską wartością zmiennej Income nie podały danych dla Age, jak i tylko osoby z niskim wiekiem nie podały swojego Income. Występuje również jedna sytuacja, w której obie zmienne nie mają podanej wartości.
Pozostałe kombinacje zmiennej nie przedstawiają żadnych zależności między sobą.
Naprawa brakujących danych
Analiza brakujących danych (NA) w zbiorze oraz ich uzupełnienie odpowiednimi wartościami. Celem jest uzyskanie kompletnego zbioru danych, który będzie gotowy do dalszej analizy.
Użycie funkcji hotdeck dla zmiennych z wartościami NA:
data <- hotdeck(data = data, variable = c("Cars", "Age", "Income", "Children", "Gender", "Marital.Status", "Home.Owner"))
colSums(is.na(data))## ID Marital.Status Gender Income
## 0 0 0 0
## Children Education Occupation Home.Owner
## 0 0 0 0
## Cars Commute.Distance Region Age
## 0 0 0 0
## Purchased.Bike Cars_imp Age_imp Income_imp
## 0 0 0 0
## Children_imp Gender_imp Marital.Status_imp Home.Owner_imp
## 0 0 0 0Powyższy output kodu potwierdza rozwiązanie problemu braków. Zostały one uzupełnione metodą Hot Deck. W rezultacie uzyskano kompletny zbiór danych, który jest gotowy do dalszej analizy statystycznej lub modelowania.
Wizualizacja Danych
Zmienna Martial.Status
ggplot(data, aes(x = Marital.Status, fill = Purchased.Bike)) +
geom_bar(position = "dodge", color = "black", size = 0.3) +
scale_fill_manual(values = c("Yes" = "green4", "No" = "red3")) +
xlab('Stan cywilny') +
ylab('Liczba osób które kupiły rower') +
ggtitle('Zakup rowerów według stanu cywilnego i decyzji o zakupie') +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.title.x = element_text(size = 12, face = "bold"),
axis.title.y = element_text(size = 12, face = "bold"),
axis.text = element_text(size = 10)
)## 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.
Na analizowanym wykresie, możemy zauważyć, iż to single częściej decydują się na zakup rowerów, prównując bezwzględnie w stosunku do żonatych/zamężnych. Większość osób w związku małżeńskim nie decyduje się na zakup rowerów. Liczba osób, o których nie mamy danych o ich stanie cywilnym jest marginalna i nie ma wpływu na całokształt analizy.
Zmienna Gender
ggplot(data, aes(x = Gender, fill = Purchased.Bike)) +
geom_bar(position = "dodge", color = "black", size = 0.3) +
scale_fill_manual(values = c("Yes" = "green4", "No" = "red3")) +
xlab('Płeć') +
ylab('Liczba osób które kupiły rower') +
ggtitle('Zakup rowerów według płci') +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.title.x = element_text(size = 12, face = "bold"),
axis.title.y = element_text(size = 12, face = "bold"),
axis.text = element_text(size = 10)
)
Z powyższego wykresu, ciężko wysunąć jednoznaczne wnioski. Obie statystyki zarówno dla mężczyzn jak i kobiet wyglądają dość tożsamo. W obu płciach delikatnie dominuje decyzja o braku zakupu roweru. Bezwzględnie to więcej mężczyzn nie kupiło roweru.
Zmienna Income
# Tworzenie nowych kategorii dochodów
data$Income.Category <- cut(data$Income,
breaks = c(0, 20000, 40000, 60000, 80000, 100000, Inf),
labels = c("0-20k", "20k-40k", "40k-60k", "60k-80k", "80k-100k", "100k+"),
right = FALSE)
# Tworzenie wykresu z rozbiciem na poszczególne kategorie dochodów oraz wartości "Yes" i "No"
ggplot(data, aes(x = Income.Category, fill = Purchased.Bike)) +
geom_bar(position = "dodge", color = "black", size = 0.3) +
scale_fill_manual(values = c("Yes" = "green4", "No" = "red3")) +
xlab('Dochód') +
ylab('Liczba osób które kupiły rower') +
ggtitle('Zakup rowerów według dochodu') +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.title.x = element_text(size = 12, face = "bold"),
axis.title.y = element_text(size = 12, face = "bold"),
axis.text = element_text(size = 10, angle = 45, hjust = 1)
)
Aby łatwiej analizować dane, pozwoliłem sobie na wyszczególnienie kilku kategorii Income. Do pewnego momentu, można zauważyć iż wyższy dochód przekłada się na większą sprzedaż. Analizując statystycznie, poza wyraźnym wzrostem w grupie dochodowej 20k-40k, wykres wykazuje cechy rozkładu normalnego. W grupach o wyższych poziomach dochodu, marginalnie więcej mamy decyzji na nie. Zapewne przy wyższych poziomach dochodu, mogą już istnieć inne alternatywy dla roweru zarówno jako środka transportu jak i dla rekreacji.
Zmienna Region
# Obliczenie procentów
data_percent <- data %>%
group_by(Region, Purchased.Bike) %>%
summarize(
Total = n(), # Liczba osób w danej grupie (Yes lub No)
.groups = "drop" # Usuwamy dodatkowe informacje o grupach
) %>%
mutate(Percentage = (Total / sum(Total)) * 100) # Procentowy udział
# Ustawienie wartości "Yes", "No" w odpowiedniej kolejności
data_percent$Purchased.Bike <- factor(data_percent$Purchased.Bike, levels = c("Yes", "No"))
# Wykres
ggplot(data_percent, aes(x = Region, y = Percentage, fill=Purchased.Bike)) +
geom_col(position = "dodge") +
xlab("Region") +
ylab("Procentowy udział osób, które kupiły rower") +
ggtitle("Zakup roweru według regionu")+
scale_fill_manual(values = c("Yes"="green4", "No"="red3"))+
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.title.x = element_text(size = 12, face = "bold"),
axis.title.y = element_text(size = 12, face = "bold"),
axis.text = element_text(size = 10, angle = 45, hjust = 1)
)
Najwięcej kupujących było z Ameryki Północnej. Widać tutaj znaczną przewagę osób, które nie kupiły roweru. W Europie było mniej więcej tyle samo osób, które zdecydowały się na rower, co tych które go nie nabyły. Z regionu Pacyfiku było więcej osób, które kupiły rower.
Zmienna Age
ggplot(data %>% filter(Purchased.Bike == "Yes"), aes(x = Age)) +
geom_bar(fill = "black") +
scale_x_continuous(breaks = seq(20, 80, by = 5), limits = c(20, 80)) +
xlab("Wiek") +
ylab("Liczba osób które kupiły rower") +
ggtitle("Zakup roweru według od wieku") +
theme_minimal() +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.title.x = element_text(size = 12, face = "bold"),
axis.title.y = element_text(size = 12, face = "bold"),
axis.text = element_text(size = 10, angle = 45, hjust = 1)
)
Największa liczba osób, które kupiły rower przypada na przedział wiekowy 35-40 lat. W grupie 40-50 jest również stosunkowo dużo kupujących. Po 55-tym roku życia widoczny jest zauważalny spadek zainteresowania kupnem roweru. Dla osób po 65-tym roku życia sprzedaż rowerów jest bardzo niska. Również grupa 25-30 charakteryzuje się niskim poziomem zakupów rowerów.
Zmienna Home.Owner
data_summary_for_pie_plot_home_owners <- data %>%
filter(Home.Owner == "Yes") %>%
summarise(
yes = sum(Purchased.Bike == "Yes"),
no = sum(Purchased.Bike == "No")
) %>%
mutate(
total = yes + no,
percent_yes = yes / total * 100,
percent_no = no / total * 100
)
plot_data <- data.frame(
purchased = c("Tak", "Nie"),
percent = c(data_summary_for_pie_plot_home_owners$percent_yes, data_summary_for_pie_plot_home_owners$percent_no)
)
plot_data <- plot_data %>%
mutate(
label = paste0(round(percent, 2), "%")
)
ggplot(plot_data, aes(x = "", y = percent, fill = purchased)) +
geom_col() +
coord_polar("y") +
scale_fill_manual(values = c("Tak" = "green4", "Nie" = "red3")) +
labs(
title = "Proporcja osób POSIADAJĄCYCH dom, które skorzystały ze sklepu",
fill = "Zakupił rower"
) +
geom_text(aes(label = label), position = position_stack(vjust = 0.5)) +
theme_void()
data_summary_for_pie_plot_NO_home_owners <- data %>%
filter(Home.Owner == "No") %>%
summarise(
yes = sum(Purchased.Bike == "Yes"),
no = sum(Purchased.Bike == "No")
) %>%
mutate(
total = yes + no,
percent_yes = yes / total * 100,
percent_no = no / total * 100
)
plot_data <- data.frame(
purchased = c("Tak", "Nie"),
percent = c(data_summary_for_pie_plot_NO_home_owners$percent_yes, data_summary_for_pie_plot_NO_home_owners$percent_no)
)
plot_data <- plot_data %>%
mutate(
label = paste0(round(percent, 2), "%")
)
ggplot(plot_data, aes(x = "", y = percent, fill = purchased)) +
geom_col() +
coord_polar("y") +
scale_fill_manual(values = c("Tak" = "green4", "Nie" = "red3")) +
labs(
title = "Proporcja osób NIEPOSIADAJĄCYCH domu, które skorzystały ze sklepu",
fill = "Kupił rower"
) +
geom_text(aes(label = label), position = position_stack(vjust = 0.5)) +
theme_void()
Na powyższych wykresach można zauważyć, osoby nieposiadające domu delikatnie częściej decydują się na kupno roweru, w stosunku do tych, które deklarują jego posiadanie.
Zmienna Commute.distance
plot_data <- data %>%
group_by(Commute.Distance, Purchased.Bike) %>%
summarise(count = n()) %>%
mutate(percentage = count / sum(count) * 100) %>%
mutate(Commute.Distance = factor(Commute.Distance, levels = c("0-1 Miles", "1-2 Miles", "2-5 Miles", "5-10 Miles", "10+ Miles")))## `summarise()` has grouped output by 'Commute.Distance'. You can override using
## the `.groups` argument.ggplot(plot_data, aes(x = Commute.Distance, y = percentage, fill = Purchased.Bike)) +
geom_col(position = "stack", width = 0.5) +
scale_y_continuous(labels = scales::percent_format(scale = 1)) +
scale_fill_manual(values = c("Yes" = "green4", "No" = "red3"), labels = c("Yes" = "Tak", "No" = "Nie")) +
geom_text(aes(label = sprintf("%.1f%%", percentage)),
position = position_stack(vjust = 0.75)) +
labs(
title = "Procentowy podział klientów sklepu według odległości dojazdu",
x = "Odległość dojazdu",
y = "Procent",
fill = "Kupił rower"
) +
theme_minimal()
Powyższy wykres przedstawia ciekawe zjawisko. Naturalnie mogłoby się wydawać, że najrzadziej kupią rower osoby posiadające najdłuższą oraz najkrótszą drogę dojazdową. Tymczasem dane przedstawiają, że faktycznie najwięcej osób posiadających średniej długości drogę (2-5 mili) decyduje się na kupno roweru, lecz na drugim miejscu znajdują się osoby z długością tylko 0-1 mili.
Zmienna Cars
plot_data <- data %>%
group_by(Cars, Purchased.Bike) %>%
summarise(count = n()) %>%
mutate(percentage = count / sum(count) * 100)## `summarise()` has grouped output by 'Cars'. You can override using the
## `.groups` argument.ggplot(plot_data, aes(x = Cars, y = percentage, fill = Purchased.Bike)) +
geom_col(position = "stack", width = 0.5) +
scale_y_continuous(labels = scales::percent_format(scale = 1)) +
scale_fill_manual(values = c("Yes" = "green4", "No" = "red3"), labels = c("Yes" = "Tak", "No" = "Nie")) +
geom_text(aes(label = sprintf("%.1f%%", percentage)),
position = position_stack(vjust = 0.75)) +
labs(
title = "Procentowy podział klientów sklepu według ilości posiadanych samochodów",
x = "Ilość posiadanych samochodów",
y = "Procent",
fill = "Kupił rower"
) +
theme_minimal()
Taki sam wykres lecz przedstawiający procent osób korzystających ze sklepu z podziałem na ilość posiadanych samochodów pokazuje już bardziej przewidywalne wyniki. Wraz ze wzrostem ilości posiadanych samochodów przez daną osobę zmniejsza się prawdopodobieństwo kupienia przez nią roweru. Mały wyjątek stanowi liczba trzech posiadanych samochodów, dla której procent osób z zakupionym rowerem jest większa o 2.5%, lecz jest to stosunkowo mała różnica, która nie wpływa na ogólny wniosek analizy tej zmiennej.
Analiza opisowa
Dochód
# Statystyki opisowe dla Income
Income <- data$Income
income_stats <- list(
count = length(Income),
mean = mean(Income, na.rm = TRUE),
sd = sd(Income, na.rm = TRUE),
min = min(Income, na.rm = TRUE),
max = max(Income, na.rm = TRUE),
median = median(Income, na.rm = TRUE)
)
list(income_stats = income_stats)## $income_stats
## $income_stats$count
## [1] 978
##
## $income_stats$mean
## [1] 55920.25
##
## $income_stats$sd
## [1] 31179.83
##
## $income_stats$min
## [1] 10000
##
## $income_stats$max
## [1] 170000
##
## $income_stats$median
## [1] 60000Mediana dochodu (środkowa) wynosi 60000 USD rocznie. Osoba z najmniejszym dochodem w skali roku zarabia 1000 USD rocznie, a osoba z największym dochodem zarabia 170 000 USD rocznie. Średnio, osoby w populacji zarabiają 55.920.25 USD w skali roku. Dodatkowo odchylenie dochodów od tej średniej wynosi 31179.83 USD w skali roku.
Płeć
# Statystyki dla Gender (binarnie)
Gender <- data$Gender
gender_stats <- table(Gender)
gender_percentage <- prop.table(gender_stats) * 100
# Wyniki
list(gender_stats = gender_stats,
gender_percentage = gender_percentage)## $gender_stats
## Gender
## Female Male
## 484 494
##
## $gender_percentage
## Gender
## Female Male
## 49.48875 50.51125Powyżej widzimy rozkład respondentów na płcie.
Stan cywilny
# Statystyki dla Marital.Status
Marital.Status <- data$Marital.Status
marital_status_stats <- table(Marital.Status)
marital_status_percentage <- prop.table(marital_status_stats) * 100
# Wyniki
list(marital_status_stats = marital_status_stats,
marital_status_percentage = marital_status_percentage)## $marital_status_stats
## Marital.Status
## Married Single
## 528 450
##
## $marital_status_percentage
## Marital.Status
## Married Single
## 53.98773 46.01227Biorąc pod uwagę, że zmienne Marital.Status i Gender, to zmienne jakościowe, cieżko jest policzyć statystyki opisowe, ponieważ dane nie są liczbowe. Można natomiast zauważyć iż w zmiennej marital.status dominują osoby będące w związku małżeńskim, które stanowią niemal 54% populacji.
Wiek
purchased_data <- data[data$Purchased.Bike=="Yes", ]
purchased_data%>%
summarize('Średnia' = mean(Age),
'Mediana' = median(Age),
'Minimum' = min(Age),
'Maksimum' = max(Age),
'Odchylenie standardowe' = sd(Age))%>%
pivot_longer(
cols = everything()
)%>%
mutate(name=cell_spec(name, bold = TRUE))%>%
kbl(escape=FALSE,col.names = NULL)%>%
add_header_above(c("WIEK OSÓB KTÓRE KUPIŁY ROWER" = 2))%>%
kable_styling(bootstrap_options=c("striped", "hover", "responsive"), position="center")| Średnia | 43.01486 |
| Mediana | 41.00000 |
| Minimum | 25.00000 |
| Maksimum | 78.00000 |
| Odchylenie standardowe | 10.15255 |
Osoby kupujące rower mają średnio 43 lata. Najmłodszy kupujący miał 25 lat, a najstarszy 78. Odchylenie standardowe wyniosło nieco ponad 10 lat, co oznacza umiarkowane zróżnicownie wieku wśród klientów.
purchased_data%>%
group_by(Gender)%>%
summarize('Średnia wieku' = mean(Age),
'Mediana wieku' = median(Age),
'Minimalny wiek' = min(Age),
'Maksymalny wiek' = max(Age),
'Odchylenie standardowe wieku' = sd(Age))%>%
arrange(desc('Suma zakupionych rowerów'))%>%
kbl()%>%
kable_styling(bootstrap_options=c("striped", "hover", "responsive"), position="center")| Gender | Średnia wieku | Mediana wieku | Minimalny wiek | Maksymalny wiek | Odchylenie standardowe wieku |
|---|---|---|---|---|---|
| Female | 42.83966 | 41 | 25 | 72 | 9.542924 |
| Male | 43.19231 | 41 | 25 | 78 | 10.752452 |
Statystyki wieku z podziałem na płeć są podobne. Można wyciągnąć wniosek, że płeć nie ma znaczenia w konteście wieku dla kupujących.
Ilość posiadanych dzieci
children <- data$Children
children_freq <- table(children)
children_prop <- prop.table(children_freq) * 100
hist(children, main = "Histogram liczby dzieci",
xlab = "Liczba dzieci", ylab = "Częstość", col = "lightblue", border = "black")
list(
summary = summary(children),
mean = mean(children, na.rm = TRUE),
median = median(children, na.rm = TRUE),
sd = sd(children, na.rm = TRUE),
variance = var(children, na.rm = TRUE),
range = range(children, na.rm = TRUE),
frequency_table = children_freq,
percentage_table = children_prop
)## $summary
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 0.000 2.000 1.902 3.000 5.000
##
## $mean
## [1] 1.90184
##
## $median
## [1] 2
##
## $sd
## [1] 1.62017
##
## $variance
## [1] 2.624951
##
## $range
## [1] 0 5
##
## $frequency_table
## children
## 0 1 2 3 4 5
## 270 168 207 132 123 78
##
## $percentage_table
## children
## 0 1 2 3 4 5
## 27.60736 17.17791 21.16564 13.49693 12.57669 7.97546W badanej próbie dominują osoby posiadające małą liczbę dzieci (0–2), co stanowi około 66% respondentów, z czego 27,6% nie posiada dzieci. Przeciętna liczba dzieci wynosi około 1,9, a mediana to 2 dzieci. Rozkład liczby dzieci jest prawoskośny – większa liczba dzieci (4–5) występuje rzadziej. Rozstęp wartości wynosi od 0 do 5 dzieci, co wskazuje na umiarkowaną zmienność w populacji. Wyniki te mogą wskazywać na zmiany w strukturze demograficznej, takie jak malejąca liczba dzieci w rodzinach, co może być efektem czynników ekonomicznych, społecznych lub kulturowych.
Wykształcenie
education <- data$Education
education_freq <- table(education)
education_prop <- prop.table(education_freq) * 100
list(
frequency_table = education_freq,
percentage_table = education_prop
)## $frequency_table
## education
## Bachelors Graduate Degree High School Partial College
## 295 170 178 260
## Partial High School
## 75
##
## $percentage_table
## education
## Bachelors Graduate Degree High School Partial College
## 30.163599 17.382413 18.200409 26.584867
## Partial High School
## 7.668712Na podstawie analizy zmiennej dotyczącej poziomu edukacji i liczby osób, które kupiły rower w sklepie rowerowym, możemy wyciągnąć następujące wnioski: Najwięcej rowerów zakupiły osoby z wykształceniem licencjackim (30,2%), drugą co do wielkości grupą są osoby z częściowo ukończonymi studiami (26,5%). Klienci z ukończoną szkołą średnią (18,2%) oraz z wykształceniem magisterskim lub wyższym (17,4%). Uzyskane wyniki zdecydowanie pokazują nam, że poziom edukacji i stopień ukończonej szkoły ma wpływ na zakup roweru.
Zawód
occupation <- data$Occupation
occupation_freq <- table(occupation)
occupation_prop <- prop.table(occupation_freq) * 100
list(
frequency_table = occupation_freq,
percentage_table = occupation_prop
)## $frequency_table
## occupation
## Clerical Management Manual Professional Skilled Manual
## 172 170 119 269 248
##
## $percentage_table
## occupation
## Clerical Management Manual Professional Skilled Manual
## 17.58691 17.38241 12.16769 27.50511 25.35787Grupa occupation, która przedstawia nam zakupioną liczbę rowerów przez osoby z różnych grup zawodowych, uzyskaliśmy następujące wyniki: Największą grupę klientów sklepu rowerowego stanowią osoby z grupy zawodowej Professional (27,5%), drugą co do wielkości grupą są osoby wykonujące prace Skilled Manual (25,4%). Osoby pracujące w zawodach Clerical (17,6%), najmniejszy udział wśród klientów mają osoby z grupy Manual (12,2%). Wyniki wskazują zdecydowaną dominację zawodów profesjonalnych oraz wykwalifikowanych pracowników.
Ilość posiadanych samochodów
cars_purchased <- data[data$Purchased.Bike=="Yes", ]
cars_not_purchased <- data[data$Purchased.Bike=="No", ]
cars_purchased %>%
summarize('Średnia' = mean(Cars)) %>%
pivot_longer(
cols = everything()
) %>%
mutate(name=cell_spec(name, bold = TRUE))%>%
kbl(escape=FALSE,col.names = NULL)%>%
add_header_above(c("ŚREDNIA ILOŚĆ SAMOCHODÓW OSOB, KTÓRE KUPIŁY ROWER" = 2))%>%
kable_styling(bootstrap_options=c("striped", "hover", "responsive"), position="center")| Średnia | 1.229299 |
cars_not_purchased %>%
summarize('Średnia' = mean(Cars)) %>%
pivot_longer(
cols = everything()
) %>%
mutate(name=cell_spec(name, bold = TRUE))%>%
kbl(escape=FALSE,col.names = NULL)%>%
add_header_above(c("ŚREDNIA ILOŚĆ SAMOCHODÓW OSOB, KTÓRE NIE KUPIŁY ROWERU" = 2))%>%
kable_styling(bootstrap_options=c("striped", "hover", "responsive"), position="center")| Średnia | 1.674556 |
Po uzyskaniu średniej ilości posiadanych samochodów klientów sklepu, możemy zauważyć zależność, że im więcej samochodów posiada klient tym jest mniejsze prawdopodobieństwo, że kupi rower. Wskazuje na to znaczna różnica pomiędzy obiema grupami - 1.67 samochodu u osób, które roweru nie kupiło, a tylko 1.23 samochodu u osób, które rower kupiły.
Korelacja pomiędzy zmiennymi numerycznymi
corr <- cor(data[c("Income", "Age", "Children")], method = "pearson")
corrplot(corr, method = "number", type = "upper", diag =FALSE)
Pomiędzy przychodem, a wiekiem zachodzi słaba korelacja dodatnia. Oznacza to, że w miarę wieku dochód nieznacznie rośnie, ale ta zależność jest dość słaba, można przyjąć, że nieznaczna.
Między przychodem, a liczbą dzieci również zachodzi słaba korelacja dodatnia. Osoby z wyższym dochodem mogą mieć nieco więcej dzieci, ale jest to także relacja słaba, co sugeruje, że dochód ma niewielki wpływ na liczbę dzieci w analizowanej grupie.
Istnieje średnia dodatnia korelacja między wiekiem a liczbą dzieci. W miarę jak wiek rośnie, liczba dzieci również rośnie. Wartość 0.53 wskazuje na wyraźniejszy związek, co może sugerować, że starsze osoby mogą mieć więcej dzieci.
Wnioskowanie statystyczne
Testy Chi-kwardrat zmiennych kategorycznych
Aby sprawdzić istotność zmiennych kategorycznych dla do testów wszystkich zmiennych postawiono tezę H0: “Zmienna nie ma wpływu na decyzję o zakupie roweru”, w opozycji do H1: “Zmienna ma wpływ na decyzję o zakupie roweru”.
categorical_vars <-c("Marital.Status","Gender","Education","Occupation", "Home.Owner", "Commute.Distance", "Region") # Lista zmiennych kategorycznych
data[] <- lapply(data, function(x) if(is.character(x)) as.factor(x) else x)
for (var in categorical_vars) {
print(ggbarstats(
data = data,
x = !!sym(var),
y = Purchased.Bike,
results.subtitle = TRUE
))
}
Istotne w decyzji o zakupie roweru, czyli tam, gdzie wartość p-value wyniosła mniej niż 0.05 okazały się zmienne: Commute.Distance, Education, Marital.Status, Region. Nieistotynymi czynnikami przy zakupie roweru są płeć, posiadanie domu i zawód.
Test ANOVA
Wykonajmy teraz test ANOVA, aby sprawdzić wpływ wykształcenia na dochód w naszych danych.
#Wykonanie testu ANOVA
anova_result <- aov(Income ~ Education, data = data)
summary(anova_result)## Df Sum Sq Mean Sq F value Pr(>F)
## Education 4 8.173e+10 2.043e+10 22.9 <2e-16 ***
## Residuals 973 8.681e+11 8.922e+08
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Powyższe zestawienie wskazuje, że wykształcenie ma istotny wływ na dochód, oraz że efekt tego wykształcenia jest silny (F = 22.85). Niska wartość p-value wskazuje również, że różnice między grupami wykształcenia są statystycznie istotne.
Test Z
Test dla zmiennej Income weryfikujący czy zmienna ma rozkład
normalny.
H0: Zmienna Income ma średnią wartość w populacji wynoszącą 60000
USD
H1: Zmienna Income nie ma średniej wartości w populacji wynoszącej 60000
USD
#Test Z
alfa=0.05
z_test <- (income_stats$mean - 60000)/income_stats$sd
print(z_test)## [1] -0.1308459p_value <- 2*pnorm(-abs(z_test))
print(p_value)## [1] 0.8958972Wybrano test Z ponieważ próbka jest za duża by wykonać test t-studenta. P-value jest większe od alfy, więc możemy odrzucić H0, mówiącą, że średnie income w populacji wynosi 60000 USD w skali roku.
Podsumowanie i wnioski końcowe
Celem przeprowadzonej analizy było określenie czynników, które mają wpływ na decyzję klienta o zakupie roweru. Aby to osiągnąć wykorzystano zbiór danych zawierający informacje demograficzne oraz ekonomiczne klientów sklepu rowerowego. Analiza uwzględniała zmienne takie jak status cywilny, płeć, dochód, liczba dzieci, wiek oraz inne dane opisujące klientów. Przed rozpoczęciem analizy wykonano detekcję i imputację brakujących danych, które uzupełniono metodą Hot Deck, co pozwoliło na stworzenie kompletnego zbioru danych do dalszej analizy. Po przygotowaniu danych przeprowadzono szeroką analizę eksploracyjną, obejmującą zarówno wizualizacje danych, jak i obliczenia statystyczne. Wykorzystano różne metody prezentacji danych, takie jak histogramy, wykresy słupkowe oraz testy statystyczne, aby zidentyfikować kluczowe trendy i zależności. Szczególną uwagę zwrócono na różnice między grupami klientów, a także na wpływ poszczególnych zmiennych na decyzję o zakupie roweru. W ramach analizy opisowej przeanalizowano również statystyki dotyczące dochodów, wieku, liczby dzieci oraz struktury wykształcenia w badanej grupie.
Przeprowadzona analiza pozwoliła na określenie kluczowych czynników wpływających na decyzję o zakupie roweru. Okazało się, że największą skłonność do zakupu wykazują osoby w wieku 35-40 lat pokonujące około 5 kilometrów do pracy. Po 55 roku życia zainteresowanie zakupem własnego roweru maleje. Osoby posiadające wykształcenie wyższe oraz większą liczbę samochodów (więcej niż 2) rzadziej kupują rowery. Płeć klienta, posiadanie domu na własność i wykonywany zawód nie mają istotnego wpływu na decyzję zakupową.