library(rvest)
library(xml2)
library(tidyverse)
library(tidytext)
library(stopwords)
library(udpipe)
library(irlba)
library(RColorBrewer)
library(wordcloud2)
library(widyr)
library(uwot)
library(ggplot2)О чем расскажут новости РНФ?
Аннотация
В этом году Российский научный фонд (РНФ) отпраздновал десятилетие со дня основания.
РНФ является одним из наиболее значимых институтов поддержки отечественной науки. Фонд проводит конкурсный отбор научных и научно-технических программ и проектов в сфере фундаментальных и поисковых исследований – исследований, направленных на получение новых знаний об основных закономерностях строения, функционирования и развития человека, общества и окружающей среды. Формально Фонд был учрежден в конце 2013 года, с этого периода на сайте РНФ было опубликовано более 5 000 новостей. Данные хорошо размечены и находятся в открытом доступе. Любой желающий может собрать из них свой датасет и проанализировать информацию, опубликованную на сайте.
Новости на сайте РНФ разделены на четыре основные рубрики:
- СМИ о Фонде
- Новости Фонд
- Интервью
- Пресс-релизы
Каждая новость отнесена к одной из категорий: биология , гуманитарные науки, инженерные науки, интервью, математика, медицина, молодежные группы, науки о Земле, новости программы, новости Фонда, прикладные проекты, сельское хозяйство, СМИ о Фонде, спецпроект, физика и космос, химия и материалы.
Разноплановая информация, объединенная общей тематикой, отлично подходит для латентно-семантического анализа (LSA). На собранных данных можно проанализирвоать семантические связи между словами, найти схожие документы, а также проследить связи между темами в контексте их развития и/или угасания.
Для работы нам понадобятся следующие библиотеки:
1 Подготовка данных
Данные собраны при помощи веб-скрапера (Selector Gadget). Датасет формируем из заголовкой новостей, ссылок на них, а также категорий и дат публикаций.
Для начала загрузим ссылку и HTML-код страницы.
url <- "https://rscf.ru/news/"
html = read_html(url)Собираем заголовки новостей.
news <- html |>
html_elements(".news-title")
news_text <- tibble(
href = news |>
html_text())
head(news_text)# A tibble: 6 × 1
href
<chr>
1 "Усилители из стекла с висмутом повысят пропускную способность интернета в 5 …
2 "Отечественные OLED-структуры и микродисплеи на их основе будут ярче и стабил…
3 "Высоковольтные полупроводниковые приборы в несколько раз превзойдут зарубежн…
4 "Ученые запустят производство особо чистого хлороводорода для микроэлектроник…
5 "Высокочистый арсенид галлия позволит создать полностью отечественные лазерны…
6 "Физики пересмотрели законы образования снежинок, дождевых капель и колец Сат…Собираем ссылки новостей.
news_link <- tibble(
href = news |>
html_attr("href"))
head(news_link)# A tibble: 6 × 1
href
<chr>
1 /news/engineering-sciences/usiliteli-iz-stekla-s-vismutom-povysyat-propusknuy…
2 /news/applied_projects/otechestvennye-oled-struktury-i-mikrodisplei-na-ikh-os…
3 /news/applied_projects/vysokovoltnye-poluprovodnikovye-pribory-v-neskolko-raz…
4 /news/applied_projects/uchenye-zapustyat-proizvodstvo-osobo-chistogo-khlorovo…
5 /news/applied_projects/vysokochistyy-arsenid-galliya-pozvolit-sozdat-polnosty…
6 /news/maths/fiziki-peresmotreli-zakony-obrazovaniya-snezhinok-dozhdevykh-kape…Собираем даты публикации новостей.
news_date <- html |>
html_elements(".news-date")
news_all_date <- tibble(
class = news_date |>
html_text())
head(news_all_date)# A tibble: 6 × 1
class
<chr>
1 "\r\n 23 декабря, 2024 "
2 "\r\n 23 декабря, 2024 "
3 "\r\n 23 декабря, 2024 "
4 "\r\n 23 декабря, 2024 "
5 "\r\n 23 декабря, 2024 "
6 "\r\n 23 декабря, 2024 "Собираем категории новостей.
news_category <- html |>
html_elements(".news-category")
news_all_category <- tibble(
class = news_category |>
html_text())
head(news_all_category)# A tibble: 6 × 1
class
<chr>
1 Инженерные науки
2 Прикладные проекты
3 Прикладные проекты
4 Прикладные проекты
5 Прикладные проекты
6 Математика Теперь нам необходимо написать цикл для сбора новостей со всех 299 страниц сайта.
Инициализируем строки для хранения данных.
all_news_text <- c()
all_news_links <- c()
all_news_date <- c()
all_category <- c()Пишем цикл, который будет проходиться по всем страницам и вытягивать из каждой новости заголовок, дату публикации, ссылку и категорию.
for (i in 1:299) {
url <- paste0("https://rscf.ru/news/?PAGEN_2=", i)
html <- read_html(url)
news <- html |>
html_elements(".news-title")
news_date <- html |>
html_elements(".news-date")
news_all_date <- news_date |>
html_text()
news_category <- html |>
html_elements(".news-category")
news_all_category <- news_category |>
html_text()
news_text <- news |>
html_text(trim = TRUE)
news_link <- news |>
html_attr("href")
all_news_text <- c(all_news_text, news_text)
all_news_links <- c(all_news_links, news_link)
all_news_date <- c(all_news_date, news_all_date)
all_category <- c(all_category, news_all_category)
}Загружаем данные в таблицу.
final_news_data <- tibble(
title = all_news_text,
link = all_news_links,
date = all_news_date,
category = all_category)
head(final_news_data)# A tibble: 6 × 4
title link date category
<chr> <chr> <chr> <chr>
1 Усилители из стекла с висмутом повысят пропускную способ… /new… "\r\… Инженер…
2 Отечественные OLED-структуры и микродисплеи на их основе… /new… "\r\… Приклад…
3 Высоковольтные полупроводниковые приборы в несколько раз… /new… "\r\… Приклад…
4 Ученые запустят производство особо чистого хлороводорода… /new… "\r\… Приклад…
5 Высокочистый арсенид галлия позволит создать полностью о… /new… "\r\… Приклад…
6 Физики пересмотрели законы образования снежинок, дождевы… /new… "\r\… Математ…Добавляем протокол доступа к полученным ссылкам (это понадобится для дальнейшей загрузки полного текста каждой новости).
final_news_data_link <- final_news_data |>
mutate(full_link = paste0("https://rscf.ru", link)) |>
select(-link)
head(final_news_data_link)# A tibble: 6 × 4
title date category full_link
<chr> <chr> <chr> <chr>
1 Усилители из стекла с висмутом повысят пропускную сп… "\r\… Инженер… https://…
2 Отечественные OLED-структуры и микродисплеи на их ос… "\r\… Приклад… https://…
3 Высоковольтные полупроводниковые приборы в несколько… "\r\… Приклад… https://…
4 Ученые запустят производство особо чистого хлороводо… "\r\… Приклад… https://…
5 Высокочистый арсенид галлия позволит создать полност… "\r\… Приклад… https://…
6 Физики пересмотрели законы образования снежинок, дож… "\r\… Математ… https://…Приводим даты к единому формату (оставляем только год, отбрасываем день и месяц, так как эта информация не нужна для аналитики).
final_news_data_link$date <- sub(".*,\\s*(\\d{4})", "\\1", final_news_data_link$date)
head(final_news_data_link)# A tibble: 6 × 4
title date category full_link
<chr> <chr> <chr> <chr>
1 Усилители из стекла с висмутом повысят пропускную сп… "202… Инженер… https://…
2 Отечественные OLED-структуры и микродисплеи на их ос… "202… Приклад… https://…
3 Высоковольтные полупроводниковые приборы в несколько… "202… Приклад… https://…
4 Ученые запустят производство особо чистого хлороводо… "202… Приклад… https://…
5 Высокочистый арсенид галлия позволит создать полност… "202… Приклад… https://…
6 Физики пересмотрели законы образования снежинок, дож… "202… Математ… https://…Добавляем в id сокращенное название документа (doc). В дальнейшем это позволит проще ориентироваться в привязке слов к документу.
final_news_data_link <- final_news_data_link |>
mutate(id = paste0(row_number(), "_doc")) |>
select(id, date, category, title, full_link)
head(final_news_data_link)# A tibble: 6 × 5
id date category title full_link
<chr> <chr> <chr> <chr> <chr>
1 1_doc "2024 " Инженерные науки Усилители из с… https://…
2 2_doc "2024 " Прикладные проекты Отечественные … https://…
3 3_doc "2024 " Прикладные проекты Высоковольтные… https://…
4 4_doc "2024 " Прикладные проекты Ученые запустя… https://…
5 5_doc "2024 " Прикладные проекты Высокочистый а… https://…
6 6_doc "2024 " Математика Физики пересмо… https://…2 Промежуточный анализ
На этом этапе можно посмотреть общее количество новостей в разрезе по годам и категориям.
category_stat<- final_news_data_link |>
group_by(date, category) |>
summarise(count = n()) |>
ungroup() |>
filter(category != "ru", category != "")
head(category_stat)# A tibble: 6 × 3
date category count
<chr> <chr> <int>
1 "2013 " Интервью 1
2 "2013 " Новости Фонда 6
3 "2014 " Интервью 31
4 "2014 " Новости Фонда 16
5 "2015 " Интервью 13
6 "2015 " Новости Фонда 44Визуализируем полученные данные.
ggplot(category_stat, aes(x = date, y = count, fill = category)) +
geom_bar(stat = "identity", position = "dodge", color = "black") +
labs(title = "Распределение новостей по категориям и годам",
x = "Год",
y = "Количество новостей") +
theme_minimal() +
theme(legend.title = element_blank())
Согласно данным на графике, тематическая рубрикация на сайте новостей РНФ изначально была довольно узкой. В 2013 году новостей практически нет (Фонд был создан зимой 2013 года). До 2018 года заметен значительный перекос в сторону рубрики “Новости фонда”. На мой взгляд, это связано с тем, что новости на сайте изначально носили преимущественно информационный характер. Например, в датасете за этот период обнаружены поздравительные тексты, рекомендации к оформлению научных статей, рекомендации к заполнению заявок, информация о победителях премий и т.д. Таким образом, можно предположить, что новости размещались в целях донесения информации, связанной с организационными обновлениями и/или требования Фонда.
Полезно “приблизить” график и лучше ознакомиться с категориями новостей с 2018 по 2024 год.
category_stat_2018 <- final_news_data_link |>
group_by(date, category) |>
summarise(count = n()) |>
ungroup() |>
filter(date >= 2018) |>
filter(category != "ru", category != "")
head(category_stat_2018)# A tibble: 6 × 3
date category count
<chr> <chr> <int>
1 "2018 " Биология 66
2 "2018 " Гуманитарные науки 20
3 "2018 " Инженерные науки 31
4 "2018 " Интервью 6
5 "2018 " Математика 19
6 "2018 " Медицина 48Визуализируем полученные данные.
ggplot(category_stat_2018, aes(x = date, y = count, fill = category)) +
geom_bar(stat = "identity", position = "dodge", color = "black") +
labs(title = "Распределение новостей по категориям и годам",
x = "Год",
y = "Количество новостей") +
theme_minimal() +
theme(legend.title = element_blank())
C 2018 года наблюдается увеличение категорий (рубрик) новостей.
В 2018 году также наблюдается аномальное количество новостей в разделе “СМИ о Фонде”.
За последние 3 года наблюдается рост интереса к химии и материалам. Далее следуют биология, физика и космос. Примечательно, что все гуманитарные науки объединены в одну категорию, т.е. мы не найдем отдельных разделов для философии и филологии. В то же время биология и химия представлены в отдельных категориях, а не объеденены в “естественные науки”. На мой взгляд, это подчеркивает отношение Фонда к химии, биологии и физике как к приоритетным областям развития науки.
3 Извлечение полного текста новостей
Перейдем к заключительному этапу сбора данных. Нам необходимо извлечь полные тексты новостей.
Проверяем извлечение текста на одной ссылке.
urls <- final_news_data_link |>
pull(full_link)
text <- read_html(urls[1]) |>
html_elements("p , .news-detail-intro") |>
html_text2()
text[1][1] "\r Ученые из Москвы и Нижнего Новгорода создали усилитель для длин волн телекоммуникационного диапазона. Это устройство размером с ноутбук состоит из стекла с добавками висмута. Когда лазерное излучение проходит сквозь такой световод, оно становится более сфокусированным. Благодаря этому передаваемый сигнал усиливается: диапазон длин волн здесь в пять раз больше, чем в современных устройствах."Пишем функцию для извлечения полного текста каждой новости.
get_text <- function(url) {
read_html(url) |>
html_elements("p , .news-detail-intro") |>
html_text2() |>
paste(collapse= " ")
}Применяем функцию, вытаскивая текст по заранее подготовленным ссылкам. Полученные данные преобразовываем в таблицу.
rnf_text <- map(urls, get_text)
rnf_text <- rnf_text|>
flatten_chr() |>
as_tibble()
rnf_textЗагружаем подготовленные данные, чтобы обойти прямую загрузку из Интернета.
load("/Users/nastasyaorlova/Desktop/data/rnf_text_.RData")Соеденяем текст с таблицей, содержащей данные метаданные о документах.
rnf_news <- final_news_data_link |>
bind_cols(rnf_text)
head(rnf_news)# A tibble: 6 × 6
id date category title full_link full_text
<chr> <chr> <chr> <chr> <chr> <chr>
1 1_doc "2024 " Инженерные науки Усил… https://… "\r Учен…
2 2_doc "2024 " Прикладные проекты Отеч… https://… "Ученые …
3 3_doc "2024 " Прикладные проекты Высо… https://… "\r Учен…
4 4_doc "2024 " Прикладные проекты Учен… https://… "\r Кома…
5 5_doc "2024 " Прикладные проекты Высо… https://… "\r Хими…
6 6_doc "2024 " Математика Физи… https://… "\r Иссл…4 Подготовка текста новостей
В некоторых случаях извлеченный текст оказался некорректным. Например, вместо кириллических символов в нескольких текстах отображались символы, сигнализирующие о технической ошибке при извлечении текста(ÐÑоÐ). Также из датасета были удалены новости, состоящие из одного или двух коротких предложений. Как правило, в этих новостях была размещена сопроводительная информация к файлам в формате pdf или краткие тематически безсодержательные сообщения (информация об открытии конкурса, ссылки на онлайн-встречи и т. д.). На этих основаниях было удалено более 60 текстов. Дополнительно были удалены тексты, содержащие пустые теги или тег “ru”. Это сократило корпус еше на 3 текста.
rnf_news_without_doc <- rnf_news |>
filter(str_trim(full_text) != "") |>
filter(!(id %in% c("3988_doc", "3984_doc", "598_doc",
"4001_doc", "2392_doc", "4864_doc",
"3694_doc", "3955_doc", "2209_doc",
"1915_doc", "5093_doc", "1306_doc",
"5271_doc", "4297_doc", "3127_doc",
"3977_doc", "5119_doc", "3966_doc",
"4294_doc", "3978_doc", "605_doc",
"803_doc", "1313_doc", "1305_doc",
"1335_doc", "1394_doc", "1524_doc", "1572_doc","1734_doc", "1752_doc", "1734_doc", "1752_doc",
"1828_doc", "1922_doc", "1975_doc", "2076_doc",
"2216_doc", "2298_doc", "2389_doc", "2399_doc",
"2936_doc", "3134_doc", "3701_doc", "3962_doc",
"3985_doc", "3987_doc", "3991_doc", "3995_doc",
"4003_doc", "4008_doc", "4304_doc", "4434_doc",
"4575_doc", "4669_doc", "4696_doc", "4793_doc", "4811_doc",
"4871_doc", "4931_doc", "4927_doc", "5100_doc", "5126_doc", "5156_doc", "5278_doc"))) |>
filter(category != "ru", category != "")Вычищаю данные.
news_prepare <- rnf_news_without_doc |>
mutate(full_text = str_replace_all(full_text, "[»«]", " ")) |>
mutate(full_text = str_remove_all(full_text, "\\d")) |>
select(id, full_text, category)
head(news_prepare)# A tibble: 6 × 3
id full_text category
<chr> <chr> <chr>
1 1_doc "\r Ученые из Москвы и Нижнего Новгорода создали усилитель для… Инженер…
2 2_doc "Ученые ИСПМ РАН намерены синтезировать более эффективные и ст… Приклад…
3 3_doc "\r Ученые ФТИ им. А.Ф. Иоффе РАН усовершенствуют высоковольтн… Приклад…
4 4_doc "\r Команда исследователей из ООО Силтрон совместно с АО Эп… Приклад…
5 5_doc "\r Химики Лаборатории технологии высокочистых материалов Ниже… Приклад…
6 6_doc "\r Исследователи из Сколтеха вывели новые математические урав… Математ…Датасет готов к лемматизации!
5 Лемматизация текста
Лемматизируем текст, а не токенизируем, так как в дальнейшем мы будем использовать латентно-семантический анализ. Т.е. нам необходимо будет искать сходство между леммами, а не словоформами.
udpipe_download_model(language = "russian-syntagrus")
russian_syntagrus <- udpipe_load_model(file = "russian-syntagrus-ud-2.5-191206.udpipe")
lemmatization <- udpipe_annotate(russian_syntagrus, news_prepare$full_text,
doc_id = news_prepare$id)Преобразовываем полученные данные в таблицу.
lemmatization <- as_tibble(lemmatization)
lemmatization Загружаем подготовленные данные, чтобы обойти утомительный процесс лемматизации.
load("/Users/nastasyaorlova/Desktop/data/lemmatization.RData")6 Подготовка лемматизированного текста
Формируем список стоп-слов. Список сформирован из наибольшего количества стоп-слов, так как в случае выбора одного или двух источников (я пробовала каждый по отдельности), остаются слова, не влияющие на тематику (день, вчера). Ресурс “nltk” не добавил в существующий список ни одного нового слова, в связи с чем я его не использовала.
stopwords_ru <- c(
stopwords("ru", source = "snowball"),
stopwords("ru", source = "marimo"),
stopwords("ru", source = "stopwords-iso")
)
stopwords_ru <- sort(unique(stopwords_ru))
length(stopwords_ru)[1] 715Дополнительная очистка данных.
Очистка некорректной лемматизации упрощает работу с текстом (-ый, -е, дефис в начале слова, единичные заглавные буквы, инициалы (М.).
clean_words <- lemmatization |>
filter(!lemma %in% stopwords_ru) |>
filter(str_detect(lemma, "[\u0400-\u04FF]")) |>
filter(!str_detect(lemma, "^[А-ЯЁ].*\\.$")) |>
filter(!str_detect(lemma, "^А$") & !str_detect(lemma, "^-.{1,2}$")) |>
filter(!str_detect(lemma, "/л")) |>
mutate(lemma = str_remove(lemma, "^-")) |>
mutate(lemma = str_remove(lemma, "\\+")) |>
mutate(lemma = str_remove(lemma, ",")) |>
filter(upos != "PUNCT")
head(clean_words)# A tibble: 6 × 14
doc_id paragraph_id sentence_id sentence token_id token lemma upos xpos
<chr> <int> <int> <chr> <chr> <chr> <chr> <chr> <chr>
1 1_doc 1 1 Ученые из Мо… 1 Учен… учен… NOUN <NA>
2 1_doc 1 1 Ученые из Мо… 3 Моск… Моск… PROPN <NA>
3 1_doc 1 1 Ученые из Мо… 5 Нижн… нижн… ADJ <NA>
4 1_doc 1 1 Ученые из Мо… 6 Новг… Новг… PROPN <NA>
5 1_doc 1 1 Ученые из Мо… 7 созд… созд… VERB <NA>
6 1_doc 1 1 Ученые из Мо… 8 усил… усил… NOUN <NA>
# ℹ 5 more variables: feats <chr>, head_token_id <chr>, dep_rel <chr>,
# deps <chr>, misc <chr>Убираем редкие наблюдения, так как редкие наблюдения, т.е. слова, встречающиеся в тексте менее 5 раз, не повлияют на тематику текстов.
news_lemma_rare <- clean_words |>
add_count(lemma) |>
filter(n > 5) |>
select(-n)
head(news_lemma_rare)# A tibble: 6 × 14
doc_id paragraph_id sentence_id sentence token_id token lemma upos xpos
<chr> <int> <int> <chr> <chr> <chr> <chr> <chr> <chr>
1 1_doc 1 1 Ученые из Мо… 1 Учен… учен… NOUN <NA>
2 1_doc 1 1 Ученые из Мо… 3 Моск… Моск… PROPN <NA>
3 1_doc 1 1 Ученые из Мо… 5 Нижн… нижн… ADJ <NA>
4 1_doc 1 1 Ученые из Мо… 6 Новг… Новг… PROPN <NA>
5 1_doc 1 1 Ученые из Мо… 7 созд… созд… VERB <NA>
6 1_doc 1 1 Ученые из Мо… 8 усил… усил… NOUN <NA>
# ℹ 5 more variables: feats <chr>, head_token_id <chr>, dep_rel <chr>,
# deps <chr>, misc <chr>Считаем наиболее часто встречающиеся слова, что может дать некоторое представление о полученных данных.
news_test_counts <- news_lemma_rare |>
group_by(lemma) |>
summarise(n = n()) |>
arrange(-n)
head(news_test_counts)# A tibble: 6 × 2
lemma n
<chr> <int>
1 научный 15393
2 ученый 15200
3 исследование 12619
4 российский 9666
5 проект 9052
6 наука 84077 Визуализация
Для наглядности составим облако слов.
pal <- brewer.pal(n = 8, name = "PuBuGn")
wordcloud2(data = news_test_counts,
size = 1,
color = pal,
backgroundColor = "white",
shape = 'circle',
minSize = 1)8 Опрятный подход
Добавляем tf idf, так как вместо показателей абсолютной встречаемости при анализе больших текстовых данных применяется tf-idf.
news_counts <- news_lemma_rare |>
count(lemma, doc_id) |>
bind_tf_idf(lemma, doc_id, n) |>
select(-n, -tf, -idf)
head(news_counts)# A tibble: 6 × 3
lemma doc_id tf_idf
<chr> <chr> <dbl>
1 D-печати 1036_doc 0.0370
2 D-печати 1059_doc 0.0382
3 D-печати 1224_doc 0.00944
4 D-печати 1267_doc 0.00527
5 D-печати 1332_doc 0.0303
6 D-печати 13_doc 0.0251 Используем специальный формат для хранения разреженных матриц.
dtm <- news_counts |>
cast_sparse(lemma, doc_id, tf_idf)9 Эмбеддинги слов
50 - это наиболее оптимальное значение. Расстояние не должно быть слишком большим или маленьким .
lsa_space<- irlba::irlba(dtm, 50)
rownames(lsa_space$u) <- rownames(dtm)
colnames(lsa_space$u) <- paste0("dim", 1:50)word_emb <- lsa_space$u |>
as.data.frame() |>
rownames_to_column("word") |>
as_tibble()
head(word_emb)# A tibble: 6 × 51
word dim1 dim2 dim3 dim4 dim5 dim6 dim7 dim8
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 D-печати -7.00e-3 5.52e-3 -8.15e-4 -1.06e-2 2.72e-3 5.12e-3 -5.80e-3 3.65e-3
2 D-печать -1.38e-3 1.03e-3 -1.13e-4 -2.07e-3 6.50e-5 5.68e-4 -5.52e-4 -8.26e-5
3 D-принт… -1.75e-3 1.24e-3 -2.05e-4 -1.95e-3 4.66e-5 7.04e-4 -1.08e-3 -1.57e-3
4 D-струк… -4.73e-4 4.02e-4 -6.10e-5 5.30e-4 -1.30e-4 2.93e-4 -9.76e-5 3.11e-4
5 G-белкий -8.36e-4 9.13e-4 -1.87e-4 2.59e-3 -9.01e-4 9.39e-4 -8.15e-4 -9.69e-4
6 MXен -7.31e-4 7.15e-4 -1.37e-4 -1.45e-3 -1.60e-4 8.61e-4 -5.41e-4 9.00e-4
# ℹ 42 more variables: dim9 <dbl>, dim10 <dbl>, dim11 <dbl>, dim12 <dbl>,
# dim13 <dbl>, dim14 <dbl>, dim15 <dbl>, dim16 <dbl>, dim17 <dbl>,
# dim18 <dbl>, dim19 <dbl>, dim20 <dbl>, dim21 <dbl>, dim22 <dbl>,
# dim23 <dbl>, dim24 <dbl>, dim25 <dbl>, dim26 <dbl>, dim27 <dbl>,
# dim28 <dbl>, dim29 <dbl>, dim30 <dbl>, dim31 <dbl>, dim32 <dbl>,
# dim33 <dbl>, dim34 <dbl>, dim35 <dbl>, dim36 <dbl>, dim37 <dbl>,
# dim38 <dbl>, dim39 <dbl>, dim40 <dbl>, dim41 <dbl>, dim42 <dbl>, …word_emb <- lsa_space$u |>
as.data.frame() |>
rownames_to_column("word") |>
as_tibble()
head(word_emb)# A tibble: 6 × 51
word dim1 dim2 dim3 dim4 dim5 dim6 dim7 dim8
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 D-печати -7.00e-3 5.52e-3 -8.15e-4 -1.06e-2 2.72e-3 5.12e-3 -5.80e-3 3.65e-3
2 D-печать -1.38e-3 1.03e-3 -1.13e-4 -2.07e-3 6.50e-5 5.68e-4 -5.52e-4 -8.26e-5
3 D-принт… -1.75e-3 1.24e-3 -2.05e-4 -1.95e-3 4.66e-5 7.04e-4 -1.08e-3 -1.57e-3
4 D-струк… -4.73e-4 4.02e-4 -6.10e-5 5.30e-4 -1.30e-4 2.93e-4 -9.76e-5 3.11e-4
5 G-белкий -8.36e-4 9.13e-4 -1.87e-4 2.59e-3 -9.01e-4 9.39e-4 -8.15e-4 -9.69e-4
6 MXен -7.31e-4 7.15e-4 -1.37e-4 -1.45e-3 -1.60e-4 8.61e-4 -5.41e-4 9.00e-4
# ℹ 42 more variables: dim9 <dbl>, dim10 <dbl>, dim11 <dbl>, dim12 <dbl>,
# dim13 <dbl>, dim14 <dbl>, dim15 <dbl>, dim16 <dbl>, dim17 <dbl>,
# dim18 <dbl>, dim19 <dbl>, dim20 <dbl>, dim21 <dbl>, dim22 <dbl>,
# dim23 <dbl>, dim24 <dbl>, dim25 <dbl>, dim26 <dbl>, dim27 <dbl>,
# dim28 <dbl>, dim29 <dbl>, dim30 <dbl>, dim31 <dbl>, dim32 <dbl>,
# dim33 <dbl>, dim34 <dbl>, dim35 <dbl>, dim36 <dbl>, dim37 <dbl>,
# dim38 <dbl>, dim39 <dbl>, dim40 <dbl>, dim41 <dbl>, dim42 <dbl>, …Преобразовываем данные в длинный формат.
word_emb_long <- word_emb |>
pivot_longer(-word, names_to = "dimension", values_to = "value") |>
mutate(dimension = as.numeric(str_remove(dimension, "dim")))
head(word_emb_long)# A tibble: 6 × 3
word dimension value
<chr> <dbl> <dbl>
1 D-печати 1 -0.00700
2 D-печати 2 0.00552
3 D-печати 3 -0.000815
4 D-печати 4 -0.0106
5 D-печати 5 0.00272
6 D-печати 6 0.00512 10 Визуализация топиков
Визуализируем несколько топиков, чтобы понять, насколько они осмыслены.
word_emb_long |>
filter(dimension < 10) |>
group_by(dimension) |>
top_n(10, abs(value)) |>
ungroup() |>
mutate(word = reorder_within(word, value, dimension)) |>
ggplot(aes(word, 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 = "Первые 9 главных компонент",
subtitle = "Топ-10 слов"
) +
scale_fill_viridis_c()
Визуализация подтверждает осмысленность тем. Так, один из топиков (3) явно представляет собой извинение перед участниками встречи за некорректную ссылку, а другой (4) относится к медицине (клетка, вирус, препарат).
11 Ближайшие “соседи”
Используем эмбеддинги для поиска ближайших “соседей”.
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()(word, dimension, value)
} |>
select(-item2)
}Ищем “соседей” слова.
nearest_neighbors(word_emb_long, "наука")# A tibble: 15,762 × 2
item1 value
<chr> <dbl>
1 наука 1
2 общество 0.819
3 партнер 0.816
4 верность 0.791
5 фотовыставка 0.790
6 флагманский 0.782
7 достижение 0.776
8 спорт 0.774
9 просвещение 0.771
10 пресс-секретарь 0.768
# ℹ 15,752 more rowsНаука ассоциируется с обществом, партнерством и просвещением.
Ищем “соседей” слова.
nearest_neighbors(word_emb_long, "событие")# A tibble: 15,762 × 2
item1 value
<chr> <dbl>
1 событие 1
2 сборник 0.928
3 знаковый 0.924
4 осветить 0.919
5 новость 0.912
6 включить 0.897
7 выпуск 0.890
8 дайджест 0.880
9 подготовить 0.875
10 лучший 0.825
# ℹ 15,752 more rowsСобытия ассоциируются с выпусками дайджестов новостей. Слова “лучший” и “знаковый” напрямую связаны с дайджестами, так как в них, как правило, публикуют самые значимые новости.
Ищем “соседей” слова.
nearest_neighbors(word_emb_long, "литература")# A tibble: 15,762 × 2
item1 value
<chr> <dbl>
1 литература 1
2 преподавание 0.772
3 легенда 0.761
4 философ 0.751
5 писатель 0.746
6 занятие 0.707
7 категория 0.685
8 реклама 0.678
9 нравиться 0.677
10 судебный 0.674
# ℹ 15,752 more rowsФилософы и писатели в новостях РНФ идут рука об руку (“хочешь философствовать - пиши романы”). Также литература часто связана с преподовательской деятельностью, что отражено в примерах. Слово “судебный” вызывает вопросы и нуждается в более детальном анализе в этом контексте.
Ищем “соседей” слова.
nearest_neighbors(word_emb_long, "грант")# A tibble: 15,762 × 2
item1 value
<chr> <dbl>
1 грант 1
2 группа 0.768
3 поддержать 0.761
4 миллион 0.725
5 исследование 0.719
6 рубль 0.701
7 отдельный 0.699
8 победить 0.672
9 составить 0.663
10 ежегодно 0.658
# ℹ 15,752 more rowsГранты в текстах ассоциируются с поддержкой, исследованиями, финансированием, ежегодными заявками и исследовательскими группами. Тематика финансирования довольна предсказуема, так как основной миссией Фонда является поддержка исследовательских проектов.
12 Похожие документы
Готовим датасет к поиску ближайших документов.
rownames(lsa_space$v) <- colnames(dtm)
colnames(lsa_space$v) <- paste0("dim", 1:50)
doc_emb <- lsa_space$v |>
as.data.frame() |>
rownames_to_column("doc") |>
as_tibble()
head(doc_emb)# A tibble: 6 × 51
doc dim1 dim2 dim3 dim4 dim5 dim6 dim7 dim8
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 1036_doc -0.0129 0.0110 -2.73e-3 -1.44e-2 -4.05e-5 0.00247 0.00313 -0.0205
2 1059_doc -0.0117 0.00751 -2.92e-4 -6.36e-4 -2.30e-4 -0.00209 0.00266 0.00678
3 1224_doc -0.0130 0.00790 -1.05e-3 -1.92e-3 -1.83e-3 0.00495 -0.00763 -0.00841
4 1267_doc -0.0109 0.00364 3.22e-4 -6.69e-3 2.98e-3 -0.00812 0.00583 0.00342
5 1332_doc -0.0144 0.0111 -2.01e-3 1.11e-2 -5.80e-3 0.0112 -0.0107 0.00472
6 13_doc -0.0126 0.00928 -1.78e-3 -8.52e-3 -6.07e-4 0.00481 -0.00218 -0.00206
# ℹ 42 more variables: dim9 <dbl>, dim10 <dbl>, dim11 <dbl>, dim12 <dbl>,
# dim13 <dbl>, dim14 <dbl>, dim15 <dbl>, dim16 <dbl>, dim17 <dbl>,
# dim18 <dbl>, dim19 <dbl>, dim20 <dbl>, dim21 <dbl>, dim22 <dbl>,
# dim23 <dbl>, dim24 <dbl>, dim25 <dbl>, dim26 <dbl>, dim27 <dbl>,
# dim28 <dbl>, dim29 <dbl>, dim30 <dbl>, dim31 <dbl>, dim32 <dbl>,
# dim33 <dbl>, dim34 <dbl>, dim35 <dbl>, dim36 <dbl>, dim37 <dbl>,
# dim38 <dbl>, dim39 <dbl>, dim40 <dbl>, dim41 <dbl>, dim42 <dbl>, …Прееобразовываем данные в длинный формат.
doc_emb_long <- doc_emb |>
pivot_longer(-doc, names_to = "dimension", values_to = "value") |>
mutate(dimension = as.numeric(str_remove(dimension, "dim")))
head(doc_emb_long)# A tibble: 6 × 3
doc dimension value
<chr> <dbl> <dbl>
1 1036_doc 1 -0.0129
2 1036_doc 2 0.0110
3 1036_doc 3 -0.00273
4 1036_doc 4 -0.0144
5 1036_doc 5 -0.0000405
6 1036_doc 6 0.00247 Ищем соседей для произвольного документа.
nearest_neighbors(doc_emb_long, "14_doc", doc = TRUE)# A tibble: 5,274 × 3
item1 item2 value
<chr> <int> <dbl>
1 14_doc 1 1
2 1308_doc 1 0.754
3 2998_doc 1 0.749
4 3816_doc 1 0.717
5 2192_doc 1 0.693
6 530_doc 1 0.688
7 1417_doc 1 0.685
8 4102_doc 1 0.677
9 2619_doc 1 0.662
10 4929_doc 1 0.662
# ℹ 5,264 more rowsnews_nearest <- rnf_news |>
filter(id %in% c("14_doc", "853_doc", "2281_doc"))
news_nearest # A tibble: 3 × 6
id date category title full_link full_text
<chr> <chr> <chr> <chr> <chr> <chr>
1 14_doc "2024 " Сельское хозяй… «Отп… https://… "\r Учен…
2 853_doc "2023 " Математика В Ро… https://… "\r Кома…
3 2281_doc "2021 " Гуманитарные н… Мысл… https://… "Ученые …Произвольно выбираем еще одну новость и ищем ее “соседей”.
nearest_neighbors(doc_emb_long, "271_doc", doc = TRUE)# A tibble: 5,274 × 3
item1 item2 value
<chr> <int> <dbl>
1 271_doc 1 1
2 959_doc 1 0.821
3 1072_doc 1 0.701
4 304_doc 1 0.696
5 3500_doc 1 0.683
6 2880_doc 1 0.662
7 82_doc 1 0.645
8 2814_doc 1 0.641
9 1241_doc 1 0.635
10 1365_doc 1 0.634
# ℹ 5,264 more rowsnews_nearest_2 <- rnf_news |>
filter(id %in% c("271_doc", "1976_doc", "2725_doc", "1196_doc"))
news_nearest_2 # A tibble: 4 × 6
id date category title full_link full_text
<chr> <chr> <chr> <chr> <chr> <chr>
1 271_doc "2024 " Сельское хозяй… Упак… https://… "\r Учен…
2 1196_doc "2023 " Инженерные нау… В ЮР… https://… "\r Хими…
3 1976_doc "2022 " Науки о Земле В КФ… https://… "\r Рабо…
4 2725_doc "2020 " Биология В Ск… https://… "Ученые …13 2D-визуализация пространства документов
Зерно можно установить любое и его необходимо установить, так как алгоритм использует псевдослучайные числа. Мне понравилась идея об установке в качестве зерна даты написания кода.
set.seed(22122024)
viz_lsa <- umap(lsa_space$v, n_neighbors = 15, n_threads = 2)Визуализируем.
tibble(doc = rownames(viz_lsa),
topic = news_prepare$category,
V1 = viz_lsa[, 1],
V2 = viz_lsa[, 2]) |>
ggplot(aes(x = V1, y = V2, label = doc, color = topic)) +
geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
theme_light()
Можно обнаружить, что новости преимущественно слипаются в одно цельное облако, а не разбиваются на отдельные тематики. Кроме того категории новостей перемешаны между собой, так что можно сказать, что тематики документов перекликаются. Но, конечно, встречаются кластеры, отделившиеся от общей массы документов.
Выделим такой тематический кластер.
Необходимо отрегулировать настройки размерности, так как график может стать уже или шире исходного, с которым мы работали локально.
tibble(doc = rownames(viz_lsa),
topic = news_prepare$category,
V1 = viz_lsa[, 1],
V2 = viz_lsa[, 2]) |>
ggplot(aes(x = V1, y = V2, label = doc, color = topic)) +
geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
annotate(geom = "rect", ymin = 8, ymax = 11, xmin = 5, xmax = 10, alpha = 0.2, color = "tomato") +
theme_light()
Приближаем интересующий нас кластер документов.
tibble(doc = rownames(viz_lsa),
topic = news_prepare$category,
V1 = viz_lsa[, 1],
V2 = viz_lsa[, 2]) |>
filter(V1 > -10 & V1 < -6) |>
filter(V2 > 2 & V2 < 6) |>
ggplot(aes(x = V1, y = V2, label = doc, color = topic)) +
geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
theme_light()
Просматриваем новости из тематического кластера, выделенного на карте красным цветом.
similar_news <- news_prepare |>
filter(id %in% c("2033_doc", "5286_doc", "3384_doc", "1495_doc"))
print(str_sub(similar_news$full_text, 1, 200))[1] "РНФ публикует свежий выпуск обзора ярких результатов грантополучателей Фонда, освещавшихся в СМИ в последние несколько месяцев. В новом дайджесте рассказано о программе, которая поможет нейрохирургам "
[2] "Обречено ли человечество на вечные пандемии? Как можно разбудить спящие гены человека для борьбы с инфекцией? Кто сегодня может сконструировать вирус и почему на Западе не создали убитую вакцину о"
[3] "Российские и зарубежные математики и биологи провели серию опытов на мышах, которая помогла им понять, как вирусные инфекции переходят в острую или хроническую стадию. Эти данные помогут понять, как з"
[4] "\r Как сообщают в Пермском государственном научно-исследовательском университете, кафедра микробиологии и иммунологии биофака ПГНИУ получила грант Российского научного фонда на исследование заболеваний"Новости медицины объединились в отдельный кластер, что подтверждает узкую направленность представленной темы (заболевания) и присутвующий интерес со строны РНФ, хоть и не такой проявленный как к областям биологии, химии и физики.
На этом этапе я убедилась в том, что модель меняет свое положение после каждого рендеринга. Тематическая кластеризация остается и темы совпадают, однако сама модель постоянно немного смещается. Из-за смещения модели плывет выделенный фрагмент тематических кластеров.
Этот образ ассоциируется у меня с перелетными птицами. Птицы объединены в стаю, похожую на облако, плавно меняющее форму. Возможно, я некорректно установила зерно или это дейтсвительно ошибка, связанная с другими факторами. Хочу отметить, что сама тематическая кластеризация сработала хорошо.
Стая птиц
Посмотрим еще один тематический кластер, наиболее отдаленный.
tibble(doc = rownames(viz_lsa),
topic = news_prepare$category,
V1 = viz_lsa[, 1],
V2 = viz_lsa[, 2]) |>
ggplot(aes(x = V1, y = V2, label = doc, color = topic)) +
geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
annotate(geom = "rect", ymin = -5, ymax = 0, xmin = -10, xmax = -5, alpha = 0.2, color = "tomato") +
theme_light()
Приближаем документы.
tibble(doc = rownames(viz_lsa),
topic = news_prepare$category,
V1 = viz_lsa[, 1],
V2 = viz_lsa[, 2]) |>
filter(V1 > -10 & V1 < -5) |>
filter(V2 > -5 & V2 < 0) |>
ggplot(aes(x = V1, y = V2, label = doc, color = topic)) +
geom_text(size = 2, alpha = 0.8, position = position_jitter(width = 1.5, height = 1.5)) +
theme_light()
similar_news_2 <- news_prepare |>
filter(id %in% c("5145_doc", "504_doc", "2736_doc", "5253_doc"))
print(str_sub(similar_news_2$full_text, 1, 100))[1] "Совет при Президенте Российской Федерации по науке и образованию начинает прием документов на соиска"
[2] "Совет при Президенте Российской Федерации по науке и образованию начинает прием документов на соиска"
[3] "\r Бумажные оригиналы представлений на соискателей премии Президента Российской Федерации в области н"
[4] "\r Совет при Президенте Российской Федерации по науке и образованию начинает прием документов на соис"Этот кластер новостей можно категоризировать как “формальный”. Он посвящен премиям Президента России. Примечательно, что в текстах встречаются буквально одни и те же формулировки, что ассоциируется с шаблонами, носящими информационный и формальный характер. В самом кластере не так много документов, что может быть связано с предварительной обработкой датасета. Как правило, такого рода объявления соодержат 1 - 2 предложения, так как необходимо максимально емко и кратко передать о сообщаемом событии, не отвлекая читателя от главного. Такие тексты были изъяты во время обработки.
Собранные данные могут быть полезны в образовательных и научных целях, благодаря этой информации можно проанализировать актуальные научные темы, а также понять какие направления развития рассматривает в качестве приориеттных РНФ. Отдельного внимания заслуживает анализ новостей из раздела “гуманитарные науки”, а именно - тематическая представленность раздела. В дальнейшем было бы интерсено посмотреть как внешние ограничения, связанные с различными социально-политическими событиями, отражаются на приоритетных (или самых поддерживаемых) темах Фонда. В этом контексте было бы интересно ответить на вопрос: чем обусловлен возникший повышенный интерес к определенной теме/людям/предметной области?
p.s.
Работа с этим датасетом напоминанила мне о том, что данные могут быть “живыми”. Они могут рождаться (появляться на сайте) даже в процессе работы с датасетом или умирать, напримр, если владелец сайта перестает его поддерживать. Новостные порталы расширяются и обновляются, поэтому полезно иметь слепок информации за определнный период.