Алия домашний экзамен

Задание 1

Прочитаем датасет, удалим пустые строки и переведем значения в числовые:

df <- read.csv("data_5.csv", sep = ";")
#удалим пустые строки
df <- subset(df, EXT1 != "NULL")
#переведем все значения в числовые
df[] <- lapply(df, function(x) as.numeric(x))

Вычислим шкалы большой пятёрки:

Создадим функцию, чтобы подсчитать корреляции между пунктами по каждой шкале:

library(reshape2)
library(ggplot2)

create_correlation_heatmap <- function(df, scale_name) {
  scale_questions <- df[, grepl(scale_name, names(df))]
  cor_matrix <- cor(scale_questions)
  melted_cor_matrix <- melt(cor_matrix)
  ggplot(data = melted_cor_matrix, aes(x = Var1, y = Var2, fill = value)) +
    geom_tile() +
    scale_fill_gradient2(low = "blue", high = "red", mid = "white", 
                         midpoint = 0, limit = c(-1,1), space = "Lab", 
                         name="Корреляция") +
    theme_minimal() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    labs(x = "", y = "", title = paste("Корреляции вопросов", scale_name))
}

Создаём тепловую карту корреляций для шкалы “Экстраверсия”:

create_correlation_heatmap(df, "EXT")

Инвертируем вопросы 2, 4, 6, 8, 10 для шкалы “Экстраверсия”.

create_correlation_heatmap(df, "EST")

Инвертируем вопросы 2, 4 для шкалы “Эмоциональная стабильность”.

create_correlation_heatmap(df, "AGR")

Инвертируем вопросы 1, 3, 5, 7 для шкалы “Доброжелательность”.

create_correlation_heatmap(df, "CSN")

Инвертируем вопросы 2, 4, 6, 8 для шкалы “Добросовестность”.

create_correlation_heatmap(df, "OPN")

Инвертируем вопросы 2, 4, 6 для шкалы “Открытость к опыту”.

Инвертируем вопросы:

invert_questions <- list(
  EXT = c(2, 4, 6, 8, 10),
  EST = c(2, 4),
  AGR = c(1, 3, 5, 7),
  CSN = c(2, 4, 6, 8),
  OPN = c(2, 4, 6)
)

for (scale in names(invert_questions)) {
  for (q in invert_questions[[scale]]) {
    question_name <- paste(scale, q, sep = "")
    df[[question_name]] <- 5 - df[[question_name]]
  }
}

Вычислим средние по шкалам и сохраним результат в новый датасет:

scales_questions <- list(
  EXT = grep("EXT", names(df), value = TRUE),
  AGR = grep("AGR", names(df), value = TRUE),
  CSN = grep("CSN", names(df), value = TRUE),
  EST = grep("EST", names(df), value = TRUE),
  OPN = grep("OPN", names(df), value = TRUE)
)

means <- sapply(scales_questions, function(questions) {
  rowMeans(df[, questions], na.rm = TRUE)
})

means_df <- as.data.frame(means)
head(means_df)

##   EXT AGR CSN EST OPN
## 1 1.9 3.1 3.2 2.5 4.0
## 2 2.1 3.0 2.7 3.3 2.1
## 3 3.2 2.8 3.2 2.1 3.0
## 4 2.3 2.5 3.3 2.4 3.0
## 5 3.3 3.8 1.7 3.1 4.3
## 6 3.9 3.7 2.4 2.6 3.7

Проверим, можно ли выделить группы респондентов:

library(factoextra)

## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa

pca_result <- prcomp(means_df, scale. = TRUE)
pca_data <- data.frame(PC1 = pca_result$x[,1], PC2 = pca_result$x[,2])

ggplot(pca_data, aes(x = PC1, y = PC2)) +
  geom_point() + 
  theme_classic() +
  labs(title = "PCA",
       x = "Первая главная компонента",
       y = "Вторая главная компонента")

Мне кажется, что кластеры выделить нельзя потому что получился такой круг.

Проверим с помощью графика каменистой осыпи:

wss <- sapply(1:10, function(k){kmeans(means_df, k, nstart = 10)$tot.withinss})
k <- 1:10

ggplot(data.frame(k, wss), aes(x = k, y = wss)) + 
  geom_line() + 
  geom_point() +
  scale_x_continuous(breaks = 1:10) +
  theme_classic() 

По графику локтя тоже не видно сгиба, который означал бы идеальное количество кластеров

Задание 2

Прочитаем и соединим два датасета по колонке “id”:

ratings <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2022/2022-01-25/ratings.csv')
details <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2022/2022-01-25/details.csv')

merged_data <- merge(ratings, details, by = "id")

Объединим в датасет нужные переменные, и проверим, как они могут коррелировать со средним рейтингом:

library(corrplot)

## corrplot 0.92 loaded

col <- colorRampPalette(c("red", "white", "blue"))(200)
our_columns <- merged_data[, c("playingtime", "minplayers", "maxplayers", "year", "minage", "average")]
cor_matrix <- cor(our_columns)
corrplot(cor_matrix, method = "circle", col = col, type = "upper", order = "hclust", tl.col="black", tl.srt=45)

На первый взгляд, средний рейтинг отрицательно связан с минимальным количеством игроков, и немного отрицательно - с максимальным количеством игроков. То есть более высокие оценки ставят играм для небольшого количества игроков. Рейтинг умеренно положительно связан с минимальным возрастом игрока, со временем игры и с годом выпуска. Значит, игроки предпочитают более длинные игры, которые вышли недавно и рассчитаны на взрослых пользователей. Максимальное количество игроков немного положительно связано с минимальным, а год выхода не сильно положительно связан с минимальным возрастом игрока.

Проверим выбросы в данных:

library(reshape2)
boxplot(our_columns$playingtime, main = "Время игры")

В переменной “время игры” есть один выброс, где значение составляет больше 50000 - удалим его:

our_columns <- our_columns[!(our_columns$playingtime > 50000), ]

boxplot(our_columns$minplayers, main = "Минимальное количество игроков")

boxplot(our_columns$maxplayers, main = "Максимальное количество игроков")

В переменной “максимальное количество игроков” есть два выброса, где значение составляет больше 300 - удалим их:

our_columns <- our_columns[!(our_columns$maxplayers > 300), ]

boxplot(our_columns$year, main = "Год выхода")

В переменной “год выхода” есть два выброса, где значение составляет больше 2100 - удалим их:

our_columns <- our_columns[!(our_columns$year > 2100), ]

boxplot(our_columns$minage, main = "Минимальный возраст игрока")

В переменной “минимальный возраст игрока” есть два выброса, где значение составляет больше 18 - удалим их:

our_columns <- our_columns[!(our_columns$minage > 18), ]

boxplot(our_columns$average, main = "Средний рейтинг", col = "lightcyan")

Перед проведением статистических тестов проверим переменные на нормальность распределения:

hist(our_columns$playingtime, main = "Время игры", breaks = 5, col = "skyblue")

Для переменной “время игры” характерно ассиметричное распределение: в основном время игры небольшое, но есть немного игр с большим временем партии

hist(our_columns$minplayers, main = "Минимальное количество игроков", breaks = 10, col = "skyblue")

у переменной “минимальное количество игроков” распределение больше похоже на нормальное, но для него характерен длинный правый хвост - наблюдается правосторонняя ассиметрия

hist(our_columns$maxplayers, main = "Максимальное количество игроков", breaks = 15, col = "skyblue")

Распределение переменной “максимальное количество игроков” не похоже на нормальное: в основном, количество игроков небольшое, но есть игры с очень большим максимальным количеством игроков

hist(our_columns$year, main = "Год выхода", breaks = 30, col = "skyblue")

Распределение переменной “год выхода” не похоже на нормальное: в основном игры вышли в районе 20-21 века, но есть игры, которые вышли очень давно

hist(our_columns$minage, main = "Минимальный возраст игрока", breaks = 30, col = "skyblue")

Распределение переменной “Минимальный возраст игрока” не очень похоже на нормальное, но напоминает его: наверное производители указывают минимальный возраст исходя из справил цензурирования, поэтому определенные возраста встречаются чаще: так, часто встречается возраст 7+, но очень редко - 8+, поэтому нормальное распределение не соблюдается

hist(our_columns$average, main = "Средний рейтинг", breaks = 30, col = "skyblue")

Распределение переменной “Средний рейтинг” напоминает нормальное с центром, немного сдвинутым в правую часть: у большинства игр рейтинг выше, чем 5/10. Так как выборка большая, мы не можем проверить нормальность тестом Шапиро-Уилка, но можем использовать тест Андерсона-Дарлинга:

library(nortest)
ad.test(our_columns$average)

## 
##  Anderson-Darling normality test
## 
## data:  our_columns$average
## A = 16.839, p-value < 2.2e-16

P-value < 2.2e-16, значит можем отклонить нулевую гипотезу о нормальности распределения

Так как распределения всех переменных ненормальные, для анализа корреляций будем использовать непараметрические критерии:

Проверка корреляций переменных с переменной “Средний рейтинг”:

cor.test(our_columns$average, our_columns$playingtime, method = "spearman")

## Warning in cor.test.default(our_columns$average, our_columns$playingtime, :
## Cannot compute exact p-value with ties

## 
##  Spearman's rank correlation rho
## 
## data:  our_columns$average and our_columns$playingtime
## S = 1.0755e+12, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##       rho 
## 0.3603078

По результатам теста Спирмена можно сказать, что существует умеренная положительная корреляция между средним рейтингом и временем игры на уровне значимости < 2.2e-16. Она составила 0.36

cor.test(our_columns$average, our_columns$minplayers, method = "spearman")

## Warning in cor.test.default(our_columns$average, our_columns$minplayers, :
## Cannot compute exact p-value with ties

## 
##  Spearman's rank correlation rho
## 
## data:  our_columns$average and our_columns$minplayers
## S = 2.0589e+12, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##        rho 
## -0.2246103

Между переменными “Средний рейтинг” и “Минимальное количество игроков” существует небольшая отрицательная корреляция, которая составила -0.22 на уровне значимости < 2.2e-16.

cor.test(our_columns$average, our_columns$maxplayers, method = "spearman")

## Warning in cor.test.default(our_columns$average, our_columns$maxplayers, :
## Cannot compute exact p-value with ties

## 
##  Spearman's rank correlation rho
## 
## data:  our_columns$average and our_columns$maxplayers
## S = 2.009e+12, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##        rho 
## -0.1949419

Между переменными “Средний рейтинг” и “Максимальное количество игроков” существует небольшая отрицательная корреляция, которая составила -0.22 на уровне значимости < 2.2e-16

cor.test(our_columns$average, our_columns$year, method = "spearman")

## Warning in cor.test.default(our_columns$average, our_columns$year, method =
## "spearman"): Cannot compute exact p-value with ties

## 
##  Spearman's rank correlation rho
## 
## data:  our_columns$average and our_columns$year
## S = 9.6268e+11, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##       rho 
## 0.4274025

Между годом выхода игры и средним рейтингом существует умеренная положительная связь, которая составила 0.43 на уровне значимости < 2.2e-16

cor.test(our_columns$average, our_columns$minage, method = "spearman")

## Warning in cor.test.default(our_columns$average, our_columns$minage, method =
## "spearman"): Cannot compute exact p-value with ties

## 
##  Spearman's rank correlation rho
## 
## data:  our_columns$average and our_columns$minage
## S = 1.2087e+12, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##       rho 
## 0.2810745

Между минимальным возрастом игрока и средним рейтингом игры наблюдается небольшая положительная корреляция. Она составила 0.28 на уровне значимости < 2.2e-16

Вывод

Результаты статистических тестов частично совпали с начальными предположениями, сделанными на основе тепловой карты корреляций. Только для переменной “год выхода” на тепловой карте наблюдалась совсем небольшая связь со средним рейтингом, а по результатам теста Спирмена она оказалась самой высокой из остальных переменных. Наверное, так получилось, потому что в матрице корреляций как базовый метод указан параметрический критерий Пирсона.

Задание 3

Прочитаем данные:

births <- scan("http://robjhyndman.com/tsdldata/data/nybirths.dat")
birthstimeseries <- ts(births, frequency=12, start=c(1946,1))

Создадим анимацию:

library(ggplot2)
library(gganimate)
library(zoo) 

dates <- seq(as.Date("1946-01-01"), by = "month", length.out = length(birthstimeseries))
births_df <- data.frame(date = dates, births = as.vector(birthstimeseries))

plot <- ggplot(births_df, aes(x = date, y = births)) +
  geom_line(color = "coral") +
  geom_point(color = "coral4") +
  labs(title = 'Количество рождённых в Нью-Йорке') +
  scale_x_date(date_breaks = "1 year", date_labels = "%Y") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
  theme_classic()

#animation <- animate(plot + transition_reveal(Date),
        #nframes = 100, fps = 10, width = 400, height = 300, renderer = gifski_renderer())
#save_gif(animation, "births_ny.gif", width = 400, height = 300, fps = 10)

На анимации мы можем увидеть увеличение количества рождений после войны, время “беби-бума”.

births_df$year <- format(births_df$date, "%Y")
births_df$month <- format(births_df$date, "%m")
average_births_by_month <- aggregate(births ~ month, data=births_df, FUN=mean)
ggplot(average_births_by_month, aes(x = as.integer(month), y = births, group = 1)) +
  geom_line(color = "coral") +
  geom_point(color = "coral4") +
  scale_x_continuous(breaks = 1:12) +
  labs(title = 'Среднее количество рождённых в месяц', x = "Месяц", y = "Среднее количество рождений") +
  theme_classic() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))

По графику среднего количества рождений для каждого месяца можно увидеть пик рождений летом и осенью, а также небольшой пик в марте и снижение числа рождений в конце осени и зимой.

В одном из kaggle-ноутбуков девушка проанализировала рождения в США с 1994 по 2014 год, и обнаружила такойе распределение частоты рождений:

И согласно этим данным, пик рождений наблюдается летом и в начале осени, а спад происходит в начале осени и зимой. Хотя эта закономерность не совсем точная, потому что в декабре за эти годы родилось больше людей, чем в июне.

Спасибо вам большое за задания!🤟🤟