Homework №11

Автор

Arina Morozova

Дата публикации

23.12.2024

Джоэль Харрис. “Сказки дядюшки Римуса”

Начало работы

Для начала подгружаю библиотеки, которые мне понадобятся

library(rvest)
library(tidyverse)
library(udpipe)
library(stopwords)
library(tidytext)
library(irlba)
library(widyr)
library(uwot)

Затем сайт с текстами сказок. Достаю текст каждой сказки и ее название, преобразовываю все это в tibble и для удобста добавляю номер для каждой сказки.

html <- read_html("https://vseskazki.su/avtorskie-skazki/skazki-dyadyushki-rimusa.html")

tbl <- tibble (name = html |>
                 html_elements(".title") |> 
                 html_text2(),
               links = html |>
                 html_elements(".title a") |>
                 html_attr("href") 
)
tbl

# A tibble: 25 × 2
   name                                           links                         
   <chr>                                          <chr>                         
 1 Как Братец Кролик перехитрил Братца Лиса       /avtorskie-skazki/skazki-dyad…
 2 Смоляное Чучелко                               /avtorskie-skazki/skazki-dyad…
 3 Как Братец Кролик опять перехитрил Братца Лиса /avtorskie-skazki/skazki-dyad…
 4 Сказка про лошадь Братца Кролика               /avtorskie-skazki/skazki-dyad…
 5 Братец Лис и Братец Кролик                     /avtorskie-skazki/skazki-dyad…
 6 Как Братец Кролик выдоил Матушку Корову        /avtorskie-skazki/skazki-dyad…
 7 В гостях у Матушки Мидоус                      /avtorskie-skazki/skazki-dyad…
 8 Как повстречались Братец Лис и Братец Черепаха /avtorskie-skazki/skazki-dyad…
 9 Неудача Братца Волка                           /avtorskie-skazki/skazki-dyad…
10 Братец Кролик и Братец Воробушек               /avtorskie-skazki/skazki-dyad…
# ℹ 15 more rows

tbl <- tbl |> 
  mutate(links = paste0("https://vseskazki.su", links)) 

links <- tbl |> 
  pull(links)

get_text <- function(html) {
  read_html(html) |> 
    html_elements(".introtxt , #system .clearfix p") |> 
    html_text2() |>
    paste(collapse= " ")
}

new_text <- map(links, get_text)

new_text <- new_text |>
  flatten_chr() |> 
  as_tibble()

my_text <- tbl |> 
  bind_cols(new_text) |>
  select(-links) |>
  rename(text = value) |>
  mutate(name = paste0("doc", row_number(), ". ", name))

Лемматизация

Для лемматизации я выбрала модель SynTagRus, сказки переведены на современный русский язык, однако были написаны еще в XIX веке, а следовательно в них могут присутствовать устаревшие слова, их не достаточно много для использования других моделей, поэтому я просто использую наиболее полный пакет из представеных.

udpipe_download_model(language = "russian-syntagrus")

syntagrus <- udpipe_load_model(file = "russian-syntagrus-ud-2.5-191206.udpipe")

Очистка данных

Очищаю таблицу с леммами от ненужных столбцов, удаляю знаки пунктуации при помощи, применяю пакет со стоп-словами и также замечаю ошибку лемматизации “Братц” вместо “Братец”, которая встречается в тексте достаточно часто, убираю ее вручную и удаляю слова встречающиеся слишком редко в тексте (меньше 5 раз).

best_text <- udpipe_annotate(syntagrus, my_text$text, doc_id = my_text$name)

text_lemma <- as_tibble(best_text) |> 
  rename(name = doc_id) |>
  select(name, lemma, upos) |>
  filter(!upos == "PUNCT")

stopwords_ru <- c(
  stopwords("ru", source = "snowball"),
  stopwords("ru", source = "marimo"),
  stopwords("ru", source = "nltk"), 
  stopwords("ru", source  = "stopwords-iso")
)

clean_lemma <- text_lemma |>
  filter(!lemma %in% stopwords_ru) |>
  filter(!lemma == "Братц") |>
  add_count(lemma) |> 
  filter(n > 5) |> 
  select(-n)

Проверяем результат очистки

clean_lemma_number <- clean_lemma |> 
  group_by(lemma) |> 
  summarise(n = n()) |> 
  arrange(-n)

Создание LSA-модели и анализ полученных данных

Упорядочиваем данные при помощи tf-idf

lemma_counts <- clean_lemma |>
  count(lemma, name) |>
  arrange(name)

lemma_tf_idf <- lemma_counts |> 
  bind_tf_idf(lemma, name, n) |> 
  arrange(tf_idf) |> 
  select(-n, -tf, -idf)

Переводим данные в формат для хранения разреженных матриц

dtm <- lemma_tf_idf |> 
  cast_sparse(lemma, name, tf_idf)

Создаем LSA-модель и начинаем работу с эмбеддингами слов

lsa_space<- irlba::irlba(dtm, 10) 

rownames(lsa_space$u) <- rownames(dtm)
colnames(lsa_space$u) <- paste0("dim", 1:10)

lemma_emb <- lsa_space$u |> 
  as.data.frame() |> 
  rownames_to_column("lemma") |> 
  as_tibble()

lemma_emb_long <- lemma_emb |> 
  pivot_longer(-lemma, names_to = "dimension", values_to = "value") |>
  mutate(dimension = as.numeric(str_remove(dimension, "dim")))

Создаю график самых частых слов в 9 разных сказках

lemma_emb_long |> 
  filter(dimension < 10) |> 
  group_by(dimension) |> 
  top_n(10, abs(value)) |> 
  ungroup() |> 
  mutate(lemma = reorder_within(lemma, value, dimension)) |> 
  ggplot(aes(lemma, value, fill = dimension)) +
  geom_col(alpha = 0.8, show.legend = FALSE) +
  facet_wrap(~dimension, scales = "free_y", ncol = 3) +
  scale_x_reordered() +
  coord_flip() +
  labs(
    x = NULL, 
    y = "Value",
    title = "Топ-10 слов в разных сказках дядюшки Римуса "
  ) +
  scale_fill_viridis_c()

Здесь мы можем увидеть, что второстепенные персонажи практически не изменяются от сказки к сказке. Почти везде присутствуют Енот, Медведь, Опоссум, Сарыч, Черепаха.

При помощи функции nearest_neighbors попробуем дать характеристику некоторым персонажам, будет ли понятно кто это, по ближайщим словам?

nearest_neighbors <- function(df, feat, doc=F) {
  inner_f <- function() {
    widely(
      ~ {
        y <- .[rep(feat, nrow(.)), ]
        res <- rowSums(. * y) / 
          (sqrt(rowSums(. ^ 2)) * sqrt(sum(.[feat, ] ^ 2)))
        
        matrix(res, ncol = 1, dimnames = list(x = names(res)))
      },
      sort = TRUE
    )}
  if (doc) {
    df |> inner_f()(doc, dimension, value) }
  else {
    df |> inner_f()(lemma, dimension, value)
  } |> 
    select(-item2)
}

nearest_neighbors(lemma_emb_long, "Сарыч")

# A tibble: 224 × 2
   item1      value
   <chr>      <dbl>
 1 Сарыч      1    
 2 дупло      0.860
 3 прийтись   0.838
 4 обещать    0.798
 5 видно      0.770
 6 ка         0.738
 7 слышно     0.724
 8 топор      0.693
 9 рассказать 0.683
10 Сарыча     0.680
# ℹ 214 more rows

соседние слова Сарыча нам практически ничего не дали, из полученных слов мы можем только предположить, что это птица.

nearest_neighbors(lemma_emb_long, "Опоссум")

# A tibble: 224 × 2
   item1   value
   <chr>   <dbl>
 1 Опоссум 1    
 2 масло   0.804
 3 трубка  0.756
 4 финик   0.749
 5 сад     0.698
 6 финика  0.692
 7 Медведь 0.642
 8 шерсть  0.615
 9 колодец 0.603
10 крик    0.583
# ℹ 214 more rows

Слова для братца Опоссума уже более информативные, мы понимаем, что этот персонаж курит трубку и вероятно любит финики.

nearest_neighbors(lemma_emb_long, "Енот")

# A tibble: 224 × 2
   item1    value
   <chr>    <dbl>
 1 Енот     1    
 2 щекотка  1.00 
 3 страх    0.991
 4 мертвый  0.990
 5 собака   0.982
 6 бояться  0.932
 7 падать   0.687
 8 как-то   0.647
 9 нос      0.624
10 поживать 0.620
# ℹ 214 more rows

Для братца Енота мы также получили хоть и небольшую но характеристику персонажа: его главный страх - это щекотка, от которой он по-видимому падает замертво.

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

Теперь попробуем так же сравнить сами сказки.

rownames(lsa_space$v) <- colnames(dtm)
colnames(lsa_space$v) <- paste0("dim", 1:10)

doc_emb <- lsa_space$v |> 
  as.data.frame() |> 
  rownames_to_column("doc") |> 
  as_tibble()

doc_emb_long <- doc_emb |> 
  pivot_longer(-doc, names_to = "dimension", values_to = "value") |>
  mutate(dimension = as.numeric(str_remove(dimension, "dim")))


doc_emb_long

# A tibble: 250 × 3
   doc                                            dimension    value
   <chr>                                              <dbl>    <dbl>
 1 doc1. Как Братец Кролик перехитрил Братца Лиса         1 -0.0135 
 2 doc1. Как Братец Кролик перехитрил Братца Лиса         2  0.0523 
 3 doc1. Как Братец Кролик перехитрил Братца Лиса         3  0.0190 
 4 doc1. Как Братец Кролик перехитрил Братца Лиса         4 -0.0136 
 5 doc1. Как Братец Кролик перехитрил Братца Лиса         5 -0.00417
 6 doc1. Как Братец Кролик перехитрил Братца Лиса         6 -0.0633 
 7 doc1. Как Братец Кролик перехитрил Братца Лиса         7  0.0734 
 8 doc1. Как Братец Кролик перехитрил Братца Лиса         8  0.261  
 9 doc1. Как Братец Кролик перехитрил Братца Лиса         9  0.0166 
10 doc1. Как Братец Кролик перехитрил Братца Лиса        10  0.0374 
# ℹ 240 more rows

nearest_neighbors(doc_emb_long, "doc1. Как Братец Кролик перехитрил Братца Лиса", doc = TRUE)

# A tibble: 25 × 3
   item1                                                            item2  value
   <chr>                                                            <int>  <dbl>
 1 doc1. Как Братец Кролик перехитрил Братца Лиса                       1 1     
 2 doc2. Смоляное Чучелко                                               1 0.967 
 3 doc4. Сказка про лошадь Братца Кролика                               1 0.595 
 4 doc5. Братец Лис и Братец Кролик                                     1 0.489 
 5 doc15. Братец Кролик — рыболов                                       1 0.375 
 6 doc17. Как Братец Лис охотился, а добыча досталась Братцу Кроли…     1 0.202 
 7 doc10. Братец Кролик и Братец Воробушек                              1 0.179 
 8 doc18. Как Братец Кролик лишился хвоста                              1 0.171 
 9 doc6. Как Братец Кролик выдоил Матушку Корову                        1 0.0933
10 doc7. В гостях у Матушки Мидоус                                      1 0.0929
# ℹ 15 more rows

Сравнение не дало особо четких резульатов, возможно все сказки сильно схожи между собой. Чтобы проверить это построим график на котором будут представлены все документы.

set.seed(23122024)
viz_lsa <- umap(lsa_space$v ,  n_neighbors = 15, n_threads = 2)

tibble(doc = rownames(viz_lsa),
       name = my_text$name,
       V1 = viz_lsa[, 1], 
       V2 = viz_lsa[, 2]) |> 
  ggplot(aes(x = V1, y = V2, label = doc, color = name)) + 
  geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
  theme_light() +
  theme(legend.position = "none")

Результат

Мы можем заметить, что сказки резрежены по всему пространству графика, а следовательно не сильно схожи друг с другом. При этом некоторые сказки все же находятся очень близко, а следовательно, некоторые общие черты в них все же прослеживаются, предпоалагаю, что схожий набор второстепенных персонажей, который хоть и не сильно, но меняется от сказки к сказке. Однако, сделать полноценное исследование на этом датасете все же не представляется возможным из-за недостаточного количества данных, что я выяснила в процессе работы с этим датасетом.